*/ REBSER *List_Func_Types(REBVAL *func)
/*
** Return a block of function arg types.
** Note: skips 0th entry.
**
***********************************************************************/
{
REBSER *block;
REBSER *words = VAL_FUNC_WORDS(func);
REBCNT n;
REBVAL *value;
REBVAL *word;
block = Make_Block(SERIES_TAIL(words));
word = BLK_SKIP(words, 1);
for (n = 1; n < SERIES_TAIL(words); word++, n++) {
value = Alloc_Tail_Blk(block);
VAL_SET(value, VAL_TYPE(word));
VAL_WORD_SYM(value) = VAL_BIND_SYM(word);
UNBIND(value);
}
return block;
}
//
// Find_Key: C
//
// Returns hash index (either the match or the new one).
// A return of zero is valid (as a hash index);
//
// Wide: width of record (normally 2, a key and a value).
//
// Modes:
// 0 - search, return hash if found or not
// 1 - search, return hash, else return -1 if not
// 2 - search, return hash, else append value and return -1
//
REBINT Find_Key(REBSER *series, REBSER *hser, const REBVAL *key, REBINT wide, REBCNT cased, REBYTE mode)
{
REBCNT *hashes;
REBCNT skip;
REBCNT hash;
REBCNT len;
REBCNT n;
REBVAL *val;
// Compute hash for value:
len = hser->tail;
hash = Hash_Value(key, len);
if (!hash) fail (Error_Has_Bad_Type(key));
// Determine skip and first index:
skip = (len == 0) ? 0 : (hash & 0x0000FFFF) % len;
if (skip == 0) skip = 1;
hash = (len == 0) ? 0 : (hash & 0x00FFFF00) % len;
// Scan hash table for match:
hashes = (REBCNT*)hser->data;
if (ANY_WORD(key)) {
while ((n = hashes[hash])) {
val = BLK_SKIP(series, (n-1) * wide);
if (
ANY_WORD(val) &&
(VAL_WORD_SYM(key) == VAL_WORD_SYM(val) ||
(!cased && VAL_WORD_CANON(key) == VAL_WORD_CANON(val)))
) return hash;
hash += skip;
if (hash >= len) hash -= len;
}
}
else if (ANY_BINSTR(key)) {
while ((n = hashes[hash])) {
val = BLK_SKIP(series, (n-1) * wide);
if (
VAL_TYPE(val) == VAL_TYPE(key)
&& 0 == Compare_String_Vals(key, val, (REBOOL)(!IS_BINARY(key) && !cased))
) return hash;
hash += skip;
if (hash >= len) hash -= len;
}
} else {
while ((n = hashes[hash])) {
val = BLK_SKIP(series, (n-1) * wide);
if (VAL_TYPE(val) == VAL_TYPE(key) && 0 == Cmp_Value(key, val, !cased)) return hash;
hash += skip;
if (hash >= len) hash -= len;
}
}
// Append new value the target series:
if (mode > 1) {
hashes[hash] = SERIES_TAIL(series) + 1;
Append_Values_Len(series, key, wide);
}
return (mode > 0) ? NOT_FOUND : hash;
}
static REBOOL same_fields(REBSER *tgt, REBSER *src)
{
struct Struct_Field *tgt_fields = (struct Struct_Field *) SERIES_DATA(tgt);
struct Struct_Field *src_fields = (struct Struct_Field *) SERIES_DATA(src);
REBCNT n;
if (SERIES_TAIL(tgt) != SERIES_TAIL(src)) {
return FALSE;
}
for(n = 0; n < SERIES_TAIL(src); n ++) {
if (tgt_fields[n].type != src_fields[n].type) {
return FALSE;
}
if (VAL_SYM_CANON(BLK_SKIP(PG_Word_Table.series, tgt_fields[n].sym))
!= VAL_SYM_CANON(BLK_SKIP(PG_Word_Table.series, src_fields[n].sym))
|| tgt_fields[n].offset != src_fields[n].offset
|| tgt_fields[n].dimension != src_fields[n].dimension
|| tgt_fields[n].size != src_fields[n].size) {
return FALSE;
}
if (tgt_fields[n].type == STRUCT_TYPE_STRUCT
&& ! same_fields(tgt_fields[n].fields, src_fields[n].fields)) {
return FALSE;
}
}
return TRUE;
}
*/ 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:
if (parent1) Collect_Object(parent1);
// Add parent2 words to binding table and BUF_WORDS:
Collect_Words(BLK_SKIP(FRM_WORD_SERIES(parent2), 1), BIND_ALL);
// Allocate child (now that we know the correct size):
wrds = Copy_Series(BUF_WORDS);
child = Make_Block(SERIES_TAIL(wrds));
value = Append_Value(child);
VAL_SET(value, REB_FRAME);
VAL_FRM_WORDS(value) = wrds;
VAL_FRM_SPEC(value) = 0;
// Copy parent1 values:
COPY_VALUES(FRM_VALUES(parent1)+1, FRM_VALUES(child)+1, SERIES_TAIL(parent1)-1);
// 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
Copy_Deep_Values(child, 1, SERIES_TAIL(child), 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(wrds);
return child;
}
static REBOOL Equal_Object(REBVAL *val, REBVAL *arg)
{
REBSER *f1;
REBSER *f2;
REBSER *w1;
REBSER *w2;
REBINT n;
if (VAL_TYPE(arg) != VAL_TYPE(val)) return FALSE;
f1 = VAL_OBJ_FRAME(val);
f2 = VAL_OBJ_FRAME(arg);
if (f1 == f2) return TRUE;
if (f1->tail != f2->tail) return FALSE;
w1 = FRM_WORD_SERIES(f1);
w2 = FRM_WORD_SERIES(f2);
if (w1->tail != w2->tail) return FALSE;
// Compare each entry:
for (n = 1; n < (REBINT)(f1->tail); n++) {
if (Cmp_Value(BLK_SKIP(w1, n), BLK_SKIP(w2, n), FALSE)) return FALSE;
// Use Compare_Values();
if (Cmp_Value(BLK_SKIP(f1, n), BLK_SKIP(f2, n), FALSE)) return FALSE;
}
return TRUE;
}
*/ void Bind_Relative(REBSER *words, REBSER *frame, REBSER *block)
/*
** Bind the words of a function block to a stack frame.
** To indicate the relative nature of the index, it is set to
** a negative offset.
**
** words: VAL_FUNC_ARGS(func)
** frame: VAL_FUNC_ARGS(func)
** block: block to bind
**
***********************************************************************/
{
REBVAL *args;
REBINT index;
REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
args = BLK_SKIP(words, 1);
CHECK_BIND_TABLE;
//Dump_Block(words);
// Setup binding table from the argument word list:
for (index = 1; NOT_END(args); args++, index++)
binds[VAL_BIND_CANON(args)] = -index;
Bind_Relative_Words(frame, block);
// Reset binding table:
for (args = BLK_SKIP(words, 1); NOT_END(args); args++)
binds[VAL_BIND_CANON(args)] = 0;
}
STOID Mold_Block_Series(REB_MOLD *mold, REBSER *series, REBCNT index, REBYTE *sep)
{
REBSER *out = mold->series;
REBOOL line_flag = FALSE; // newline was part of block
REBOOL had_lines = FALSE;
REBVAL *value = BLK_SKIP(series, index);
if (!sep) sep = "[]";
if (IS_END(value)) {
Append_Bytes(out, sep);
return;
}
// Recursion check: (variation of: Find_Same_Block(MOLD_LOOP, value))
for (value = BLK_HEAD(MOLD_LOOP); NOT_END(value); value++) {
if (VAL_SERIES(value) == series) {
Emit(mold, "C...C", sep[0], sep[1]);
return;
}
}
value = Append_Value(MOLD_LOOP);
Set_Block(value, series);
if (sep[1]) {
Append_Byte(out, sep[0]);
mold->indent++;
}
// else out->tail--; // why?????
value = BLK_SKIP(series, index);
while (NOT_END(value)) {
if (VAL_GET_LINE(value)) {
if (sep[1] || line_flag) New_Indented_Line(mold);
had_lines = TRUE;
}
line_flag = TRUE;
Mold_Value(mold, value, TRUE);
value++;
if (NOT_END(value))
Append_Byte(out, (sep[0] == '/') ? '/' : ' ');
}
if (sep[1]) {
mold->indent--;
if (VAL_GET_LINE(value) || had_lines) New_Indented_Line(mold);
Append_Byte(out, sep[1]);
}
Remove_Last(MOLD_LOOP);
}
*/ RL_API REBYTE *RL_Word_String(u32 word)
/*
** 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.
**
***********************************************************************/
{
REBYTE *s1, *s2;
// !!This code should use a function from c-words.c (but nothing perfect yet.)
if (word == 0 || word >= PG_Word_Table.series->tail) return 0;
s1 = VAL_SYM_NAME(BLK_SKIP(PG_Word_Table.series, word));
s2 = OS_ALLOC_ARRAY(REBYTE, LEN_BYTES(s1) + 1);
COPY_BYTES(s2, s1, LEN_BYTES(s1) + 1);
return s2;
}
*/ REBYTE *Get_Sym_Name(REBCNT num)
/*
***********************************************************************/
{
if (num == 0 || num >= PG_Word_Table.series->tail) return (REBYTE*)"???";
return VAL_SYM_NAME(BLK_SKIP(PG_Word_Table.series, num));
}
*/ static void Expand_Word_Table(void)
/*
** Expand the hash table part of the word_table by allocating
** the next larger table size and rehashing all the words of
** the current table. Free the old hash array.
**
***********************************************************************/
{
REBCNT *hashes;
REBVAL *word;
REBINT hash;
REBCNT size;
REBINT skip;
REBCNT n;
// Allocate a new hash table:
Expand_Hash(PG_Word_Table.hashes);
// Debug_Fmt("WORD-TABLE: expanded (%d symbols, %d slots)", PG_Word_Table.series->tail, PG_Word_Table.hashes->tail);
// Rehash all the symbols:
word = BLK_SKIP(PG_Word_Table.series, 1);
hashes = (REBCNT *)PG_Word_Table.hashes->data;
size = PG_Word_Table.hashes->tail;
for (n = 1; n < PG_Word_Table.series->tail; n++, word++) {
hash = Hash_Word(VAL_SYM_NAME(word), -1);
skip = (hash & 0x0000FFFF) % size;
if (skip == 0) skip = 1;
hash = (hash & 0x00FFFF00) % size;
while (hashes[hash]) {
hash += skip;
if (hash >= (REBINT)size) hash -= size;
}
hashes[hash] = n;
}
}
*/ void Init_Errors(REBVAL *errors)
/*
***********************************************************************/
{
REBSER *errs;
REBVAL *val;
// Create error objects and error type objects:
*ROOT_ERROBJ = *Get_System(SYS_STANDARD, STD_ERROR);
errs = Construct_Object(0, VAL_BLK(errors), 0);
Set_Object(Get_System(SYS_CATALOG, CAT_ERRORS), errs);
Set_Root_Series(TASK_ERR_TEMPS, Make_Block(3));
// Create objects for all error types:
for (val = BLK_SKIP(errs, 1); NOT_END(val); val++) {
errs = Construct_Object(0, VAL_BLK(val), 0);
SET_OBJECT(val, errs);
}
// Catch top level errors, to provide decent output:
PUSH_STATE(Top_State, Saved_State);
if (SET_JUMP(Top_State)) {
POP_STATE(Top_State, Saved_State);
DSP++; // Room for return value
Catch_Error(DS_TOP); // Stores error value here
Print_Value(DS_TOP, 0, FALSE);
Crash(RP_NO_CATCH);
}
SET_STATE(Top_State, Saved_State);
}
*/ void Set_Error_Type(ERROR_OBJ *error)
/*
** Sets error type and id fields based on code number.
**
***********************************************************************/
{
REBSER *cats; // Error catalog object
REBSER *cat; // Error category object
REBCNT n; // Word symbol number
REBCNT code;
code = VAL_INT32(&error->code);
// Set error category:
n = code / 100 + 1;
cats = VAL_OBJ_FRAME(Get_System(SYS_CATALOG, CAT_ERRORS));
if (code >= 0 && n < SERIES_TAIL(cats) &&
NZ(cat = VAL_SERIES(BLK_SKIP(cats, n)))
) {
Set_Word(&error->type, FRM_WORD_SYM(cats, n), cats, n);
// Find word related to the error itself:
n = code % 100 + 3;
if (n < SERIES_TAIL(cat))
Set_Word(&error->id, FRM_WORD_SYM(cat, n), cat, n);
}
}
*/ RL_API int RL_Start(REBYTE *bin, REBINT len, REBCNT flags)
/*
** Evaluate the default boot function.
**
** Returns:
** Zero on success, otherwise indicates an error occurred.
** Arguments:
** bin - optional startup code (compressed), can be null
** len - length of above bin
** flags - special flags
** Notes:
** This function completes the startup sequence by calling
** the sys/start function.
**
***********************************************************************/
{
REBVAL *val;
REBSER spec = {0};
REBSER *ser;
if (bin) {
spec.data = bin;
spec.tail = len;
ser = Decompress(&spec, 0, -1, 10000000, 0);
if (!ser) return 1;
val = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_HOST);
Set_Binary(val, ser);
}
return Init_Mezz(0);
}
*/ 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));
}
STOID Form_Block_Series(REBSER *blk, REBCNT index, REB_MOLD *mold, REBSER *frame)
{
// Form a series (part_mold means mold non-string values):
REBINT n;
REBINT len = SERIES_TAIL(blk) - index;
REBVAL *val;
REBVAL *wval;
if (len < 0) len = 0;
for (n = 0; n < len;) {
val = BLK_SKIP(blk, index+n);
wval = 0;
if (frame && (IS_WORD(val) || IS_GET_WORD(val))) {
wval = Find_Word_Value(frame, VAL_WORD_SYM(val));
if (wval) val = wval;
}
Mold_Value(mold, val, wval != 0);
n++;
if (GET_MOPT(mold, MOPT_LINES)) {
Append_Byte(mold->series, LF);
}
else {
// Add a space if needed:
if (n < len && mold->series->tail
&& *UNI_LAST(mold->series) != LF
&& !GET_MOPT(mold, MOPT_TIGHT)
)
Append_Byte(mold->series, ' ');
}
}
}
*/ static REBFLG Get_Struct_Var(REBSTU *stu, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
struct Struct_Field *field = NULL;
REBCNT i = 0;
field = (struct Struct_Field *)SERIES_DATA(stu->fields);
for (i = 0; i < SERIES_TAIL(stu->fields); i ++, field ++) {
if (VAL_WORD_CANON(word) == VAL_SYM_CANON(BLK_SKIP(PG_Word_Table.series, field->sym))) {
if (field->array) {
REBSER *ser = Make_Array(field->dimension);
REBCNT n = 0;
for (n = 0; n < field->dimension; n ++) {
REBVAL elem;
get_scalar(stu, field, n, &elem);
Append_Value(ser, &elem);
}
Val_Init_Block(val, ser);
} else {
get_scalar(stu, field, 0, val);
}
return TRUE;
}
}
return FALSE;
}
*/ static void Trim_Block(REBSER *ser, REBCNT index, REBCNT flags)
/*
** See Trim_String().
**
***********************************************************************/
{
REBVAL *blk = BLK_HEAD(ser);
REBCNT out = index;
REBCNT end = ser->tail;
if (flags & AM_TRIM_TAIL) {
for (; end >= (index+1); end--) {
if (VAL_TYPE(blk+end-1) > REB_NONE) break;
}
Remove_Series(ser, end, ser->tail - end);
if (!(flags & AM_TRIM_HEAD) || index >= end) return;
}
if (flags & AM_TRIM_HEAD) {
for (; index < end; index++) {
if (VAL_TYPE(blk+index) > REB_NONE) break;
}
Remove_Series(ser, out, index - out);
}
if (flags == 0) {
for (; index < end; index++) {
if (VAL_TYPE(blk+index) > REB_NONE) {
*BLK_SKIP(ser, out) = blk[index];
out++;
}
}
Remove_Series(ser, out, end - out);
}
}
*/ REBINT PD_Frame(REBPVS *pvs)
/*
** pvs->value points to the first value in frame (SELF).
**
***********************************************************************/
{
REBCNT sym;
REBCNT s;
REBVAL *word;
REBVAL *val;
if (IS_WORD(pvs->select)) {
sym = VAL_WORD_SYM(pvs->select);
s = SYMBOL_TO_CANON(sym);
word = BLK_SKIP(VAL_FRM_WORDS(pvs->value), 1);
for (val = pvs->value + 1; NOT_END(val); val++, word++) {
if (sym == VAL_BIND_SYM(word) || s == VAL_BIND_CANON(word)) {
if (VAL_GET_OPT(word, OPTS_HIDE)) break;
if (VAL_PROTECTED(word)) Trap1(RE_LOCKED_WORD, word);
pvs->value = val;
return PE_SET;
}
}
}
return PE_BAD_SELECT;
}
*/ void *Use_Port_State(REBSER *port, REBCNT device, REBCNT size)
/*
** Use private state area in a port. Create if necessary.
** The size is that of a binary structure used by
** the port for storing internal information.
**
***********************************************************************/
{
REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
// If state is not a binary structure, create it:
if (!IS_BINARY(state)) {
REBSER *data = Make_Binary(size);
REBREQ *req = (REBREQ*)STR_HEAD(data);
req->clen = size;
CLEAR(STR_HEAD(data), size);
//data->tail = size; // makes it easier for ACCEPT to clone the port
SET_FLAG(req->flags, RRF_ALLOC); // not on stack
req->port = port;
req->device = device;
Val_Init_Binary(state, data);
}
return (void *)VAL_BIN(state);
}
*/ REBSER *Check_Func_Spec(REBSER *block)
/*
** Check function spec of the form:
**
** ["description" arg "notes" [type! type2! ...] /ref ...]
**
** Throw an error for invalid values.
**
***********************************************************************/
{
REBVAL *blk;
REBSER *words;
REBINT n = 0;
REBVAL *value;
blk = BLK_HEAD(block);
words = Collect_Frame(BIND_ALL | BIND_NO_DUP | BIND_NO_SELF, 0, blk);
// !!! needs more checks
for (; NOT_END(blk); blk++) {
switch (VAL_TYPE(blk)) {
case REB_BLOCK:
// Skip the SPEC block as an arg. Use other blocks as datatypes:
if (n > 0) Make_Typeset(VAL_BLK(blk), BLK_SKIP(words, n), 0);
break;
case REB_STRING:
case REB_INTEGER: // special case used by datatype test actions
break;
case REB_WORD:
case REB_GET_WORD:
case REB_LIT_WORD:
n++;
break;
case REB_REFINEMENT:
// Refinement only allows logic! and none! for its datatype:
n++;
value = BLK_SKIP(words, n);
VAL_TYPESET(value) = (TYPESET(REB_LOGIC) | TYPESET(REB_NONE));
break;
case REB_SET_WORD:
default:
Trap1_DEAD_END(RE_BAD_FUNC_DEF, blk);
}
}
return words; //Create_Frame(words, 0);
}
*/ void Do_Routine(REBVAL *routine)
/*
*/
{
//RL_Print("%s, %d\n", __func__, __LINE__);
REBSER *args = Copy_Values(BLK_SKIP(DS_Series, DS_ARG_BASE + 1), SERIES_TAIL(VAL_FUNC_ARGS(routine)) - 1);
Call_Routine(routine, args, DS_OUT);
}
*/ REBVAL *Obj_Word(REBVAL *value, REBCNT index)
/*
** Return pointer to the nth WORD of an object.
**
***********************************************************************/
{
REBSER *obj = VAL_OBJ_WORDS(value);
return BLK_SKIP(obj, index);
}
*/ void Rebind_Frame(REBSER *src_frame, REBSER *dst_frame)
/*
** Clone old src_frame to new dst_frame knowing
** which types of values need to be copied, deep copied, and rebound.
**
***********************************************************************/
{
// Rebind all values:
Rebind_Block(src_frame, dst_frame, BLK_SKIP(dst_frame, 1), REBIND_FUNC);
}
*/ 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;
}
*/ REBFLG Is_Port_Open(REBSER *port)
/*
** Standard method for checking if port is open.
** A convention. Not all ports use this method.
**
***********************************************************************/
{
REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
if (!IS_BINARY(state)) return FALSE;
return IS_OPEN(VAL_BIN_DATA(state));
}
*/ 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;
}
*/ REBVAL *Obj_Value(REBVAL *value, REBCNT index)
/*
** Return pointer to the nth VALUE of an object.
** Return zero if the index is not valid.
**
***********************************************************************/
{
REBSER *obj = VAL_OBJ_FRAME(value);
if (index >= SERIES_TAIL(obj)) return 0;
return BLK_SKIP(obj, index);
}
*/ void Set_Port_Open(REBSER *port, REBFLG flag)
/*
** Standard method for setting a port open/closed.
** A convention. Not all ports use this method.
**
***********************************************************************/
{
REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
if (IS_BINARY(state)) {
if (flag) SET_OPEN(VAL_BIN_DATA(state));
else SET_CLOSED(VAL_BIN_DATA(state));
}
}
*/ void Bind_Frame(REBSER *obj)
/*
** Clone a frame, knowing which types of values need to be
** copied, deep copied, and rebound.
**
***********************************************************************/
{
REBVAL *val;
REBOOL funcs = FALSE;
//DISABLE_GC;
// Copy functions:
for (val = BLK_SKIP(obj, 1); NOT_END(val); val++) {
if (IS_FUNCTION(val)) {
Clone_Function(val, val);
funcs = TRUE;
}
else if (IS_CLOSURE(val)) {
funcs = TRUE;
}
}
// Rebind all values:
Bind_Block(obj, BLK_SKIP(obj, 1), BIND_DEEP | BIND_FUNC);
if (funcs) {
// Rebind functions:
for (val = BLK_SKIP(obj, 1); NOT_END(val); val++) {
if (IS_FUNCTION(val)) {
Bind_Relative(VAL_FUNC_ARGS(val), VAL_FUNC_BODY(val), VAL_FUNC_BODY(val));
}
else if (IS_CLOSURE(val)) {
}
}
}
//ENABLE_GC;
}
*/ REBVAL *Find_Word_Value(REBSER *frame, REBCNT sym)
/*
** Search a frame looking for the given word symbol and
** return the value for the word. Locate it by matching
** the canon word identifiers. Return NULL if not found.
**
***********************************************************************/
{
REBINT n;
if (!frame) return 0;
n = Find_Word_Index(frame, sym, FALSE);
if (!n) return 0;
return BLK_SKIP(frame, n);
}