*/ REBINT CT_Port(REBVAL *a, REBVAL *b, REBINT mode)
/*
***********************************************************************/
{
if (mode < 0) return -1;
return VAL_OBJ_FRAME(a) == VAL_OBJ_FRAME(b);
}
*/ REBINT PD_Object(REBPVS *pvs)
/*
***********************************************************************/
{
REBINT n = 0;
if (!VAL_OBJ_FRAME(pvs->value)) {
return PE_NONE; // Error objects may not have a frame.
}
if (IS_WORD(pvs->select)) {
n = Find_Word_Index(VAL_OBJ_FRAME(pvs->value), VAL_WORD_SYM(pvs->select), FALSE);
}
// else if (IS_INTEGER(pvs->select)) {
// n = Int32s(pvs->select, 1);
// }
else return PE_BAD_SELECT;
if (n <= 0 || (REBCNT)n >= SERIES_TAIL(VAL_OBJ_FRAME(pvs->value)))
return PE_BAD_SELECT;
if (pvs->setval && IS_END(pvs->path+1) && VAL_PROTECTED(VAL_FRM_WORD(pvs->value, n)))
Trap1(RE_LOCKED_WORD, pvs->select);
pvs->value = VAL_OBJ_VALUES(pvs->value) + n;
return PE_SET;
// if setval, check PROTECT mode!!!
// VAL_FLAGS((VAL_OBJ_VALUES(value) + n)) &= ~FLAGS_CLEAN;
}
*/ REBVAL *Find_Error_Info(ERROR_OBJ *error, REBINT *num)
/*
** Return the error message needed to print an error.
** Must scan the error catalog and its error lists.
** Note that the error type and id words no longer need
** to be bound to the error catalog context.
** If the message is not found, return null.
**
***********************************************************************/
{
REBSER *frame;
REBVAL *obj1;
REBVAL *obj2;
if (!IS_WORD(&error->type) || !IS_WORD(&error->id)) return 0;
// Find the correct error type object in the catalog:
frame = VAL_OBJ_FRAME(Get_System(SYS_CATALOG, CAT_ERRORS));
obj1 = Find_Word_Value(frame, VAL_WORD_SYM(&error->type));
if (!obj1) return 0;
// Now find the correct error message for that type:
frame = VAL_OBJ_FRAME(obj1);
obj2 = Find_Word_Value(frame, VAL_WORD_SYM(&error->id));
if (!obj2) return 0;
if (num) {
obj1 = Find_Word_Value(frame, SYM_CODE);
*num = VAL_INT32(obj1)
+ Find_Word_Index(frame, VAL_WORD_SYM(&error->id), FALSE)
- Find_Word_Index(frame, SYM_TYPE, FALSE) - 1;
}
return obj2;
}
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;
}
static REBOOL Same_Object(REBVAL *val, REBVAL *arg)
{
if (
VAL_TYPE(arg) == VAL_TYPE(val) &&
//VAL_OBJ_SPEC(val) == VAL_OBJ_SPEC(arg) &&
VAL_OBJ_FRAME(val) == VAL_OBJ_FRAME(arg)
) return TRUE;
return FALSE;
}
//
// Ret_Query_Net: C
//
static void Ret_Query_Net(REBSER *port, REBREQ *sock, REBVAL *ret)
{
REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
REBSER *obj;
if (!info || !IS_OBJECT(info))
fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
obj = Copy_Array_Shallow(VAL_OBJ_FRAME(info));
MANAGE_SERIES(obj);
Val_Init_Object(ret, obj);
Set_Tuple(
OFV(obj, STD_NET_INFO_LOCAL_IP),
cast(REBYTE*, &sock->special.net.local_ip),
4
);
Set_Tuple(
OFV(obj, STD_NET_INFO_REMOTE_IP),
cast(REBYTE*, &sock->special.net.remote_ip),
4
);
SET_INTEGER(OFV(obj, STD_NET_INFO_LOCAL_PORT), sock->special.net.local_port);
SET_INTEGER(OFV(obj, STD_NET_INFO_REMOTE_PORT), sock->special.net.remote_port);
}
/***********************************************************************
**
** Get_Obj_Mods -- return a block of modified words from an object
**
***********************************************************************/
REBVAL *Get_Obj_Mods(REBFRM *frame, REBVAL **inter_block)
{
REBVAL *obj = D_ARG(1);
REBVAL *words, *val;
REBFRM *frm = VAL_OBJ_FRAME(obj);
REBSER *ser = Make_Block(2);
REBOOL clear = D_REF(2);
//DISABLE_GC;
val = BLK_HEAD(frm->values);
words = BLK_HEAD(frm->words);
for (; NOT_END(val); val++, words++)
if (!(VAL_FLAGS(val) & FLAGS_CLEAN)) {
Append_Val(ser, words);
if (clear) VAL_FLAGS(val) |= FLAGS_CLEAN;
}
if (!STR_LEN(ser)) {
ENABLE_GC;
goto is_none;
}
Bind_Block(frm, BLK_HEAD(ser), FALSE);
VAL_SERIES(Temp_Blk_Value) = ser;
//ENABLE_GC;
return Temp_Blk_Value;
}
*/ void Ret_Query_File(REBSER *port, REBREQ *file, REBVAL *ret)
/*
** Query file and set RET value to resulting STD_FILE_INFO object.
**
***********************************************************************/
{
REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
REBSER *obj;
REBSER *ser;
if (!info || !IS_OBJECT(info)) Trap_Port(RE_INVALID_SPEC, port, -10);
obj = CLONE_OBJECT(VAL_OBJ_FRAME(info));
SET_OBJECT(ret, obj);
Init_Word_Unbound(
OFV(obj, STD_FILE_INFO_TYPE),
REB_WORD,
GET_FLAG(file->modes, RFM_DIR) ? SYM_DIR : SYM_FILE
);
SET_INTEGER(OFV(obj, STD_FILE_INFO_SIZE), file->special.file.size);
Set_File_Date(file, OFV(obj, STD_FILE_INFO_DATE));
ser = To_REBOL_Path(file->special.file.path, 0, OS_WIDE, 0);
Set_Series(REB_FILE, OFV(obj, STD_FILE_INFO_NAME), ser);
}
*/ static void Ret_Query_Net(REBSER *port, REBREQ *sock, REBVAL *ret)
/*
***********************************************************************/
{
REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
REBSER *obj;
if (!info || !IS_OBJECT(info)) Trap_Port(RE_INVALID_SPEC, port, -10);
obj = CLONE_OBJECT(VAL_OBJ_FRAME(info));
SET_OBJECT(ret, obj);
Set_Tuple(
OFV(obj, STD_NET_INFO_LOCAL_IP),
cast(REBYTE*, &sock->special.net.local_ip),
4
);
Set_Tuple(
OFV(obj, STD_NET_INFO_REMOTE_IP),
cast(REBYTE*, &sock->special.net.remote_ip),
4
);
SET_INTEGER(OFV(obj, STD_NET_INFO_LOCAL_PORT), sock->special.net.local_port);
SET_INTEGER(OFV(obj, STD_NET_INFO_REMOTE_PORT), sock->special.net.remote_port);
}
*/ REBVAL *Find_In_Contexts(REBCNT sym, REBVAL *where)
/*
** Search a block of objects for a given word symbol and
** return the value for the word. NULL if not found.
**
***********************************************************************/
{
REBVAL *val;
for (; NOT_END(where); where++) {
if (IS_WORD(where)) {
val = Get_Var(where);
}
else if (IS_PATH(where)) {
Do_Path(&where, 0);
val = DS_TOP; // only safe for short time!
}
else
val = where;
if (IS_OBJECT(val)) {
val = Find_Word_Value(VAL_OBJ_FRAME(val), sym);
if (val) return val;
}
}
return 0;
}
*/ REBSER *Make_Error(REBINT code, REBVAL *arg1, REBVAL *arg2, REBVAL *arg3)
/*
** Create and init a new error object.
**
***********************************************************************/
{
REBSER *err; // Error object
ERROR_OBJ *error; // Error object values
if (PG_Boot_Phase < BOOT_ERRORS) Crash(RP_EARLY_ERROR, code); // Not far enough!
// Make a copy of the error object template:
err = CLONE_OBJECT(VAL_OBJ_FRAME(ROOT_ERROBJ));
error = ERR_VALUES(err);
// Set error number:
SET_INTEGER(&error->code, (REBINT)code);
Set_Error_Type(error);
// Set error argument values:
if (arg1) error->arg1 = *arg1;
if (arg2) error->arg2 = *arg2;
if (arg3) error->arg3 = *arg3;
// Set backtrace and location information:
if (DSF > 0) {
// Where (what function) is the error:
Set_Block(&error->where, Make_Backtrace(0));
// Nearby location of the error (in block being evaluated):
error->nearest = *DSF_BACK(DSF);
}
return err;
}
*/ void Set_Object(REBVAL *value, REBSER *series)
/*
***********************************************************************/
{
VAL_SET(value, REB_OBJECT);
VAL_OBJ_FRAME(value) = series;
}
*/ 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);
}
}
*/ REBCNT Find_Action(REBVAL *object, REBCNT action)
/*
** Given an action number, return the action's index in
** the specified object. If not found, a zero is returned.
**
***********************************************************************/
{
return Find_Word_Index(VAL_OBJ_FRAME(object), VAL_BIND_SYM(Get_Action_Word(action)), FALSE);
}
*/ REBVAL *Get_Object(REBVAL *objval, REBCNT index)
/*
** Get an instance variable from an object value.
**
***********************************************************************/
{
REBSER *obj = VAL_OBJ_FRAME(objval);
ASSERT1(IS_FRAME(BLK_HEAD(obj)), RP_BAD_OBJ_FRAME);
ASSERT1(index < SERIES_TAIL(obj), RP_BAD_OBJ_INDEX);
return FRM_VALUES(obj) + index;
}
*/ 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;
}
*/ 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);
}
STOID Mold_Object(REBVAL *value, REB_MOLD *mold)
{
REBSER *wser;
REBVAL *words;
REBVAL *vals; // first value is context
REBCNT n;
REBOOL indented = !GET_MOPT(mold, MOPT_INDENT);
ASSERT(VAL_OBJ_FRAME(value), RP_NO_OBJECT_FRAME);
wser = VAL_OBJ_WORDS(value);
// if (wser < 1000)
// Dump_Block_Raw(VAL_OBJ_FRAME(value), 0, 1);
words = BLK_HEAD(wser);
vals = VAL_OBJ_VALUES(value); // first value is context
Pre_Mold(value, mold);
Append_Byte(mold->series, '[');
// Prevent infinite looping:
if (Find_Same_Block(MOLD_LOOP, value) > 0) {
Append_Bytes(mold->series, "...]");
return;
}
Append_Val(MOLD_LOOP, value);
mold->indent++;
for (n = 1; n < SERIES_TAIL(wser); n++) {
if (
!VAL_GET_OPT(words+n, OPTS_HIDE) &&
((VAL_TYPE(vals+n) > REB_NONE) || !GET_MOPT(mold, MOPT_NO_NONE))
){
if(indented)
New_Indented_Line(mold);
else if (n > 1)
Append_Byte(mold->series, ' ');
Append_UTF8(mold->series, Get_Sym_Name(VAL_WORD_SYM(words+n)), -1);
//Print("Slot: %s", Get_Sym_Name(VAL_WORD_SYM(words+n)));
Append_Bytes(mold->series, ": ");
if (IS_WORD(vals+n) && !GET_MOPT(mold, MOPT_MOLD_ALL)) Append_Byte(mold->series, '\'');
Mold_Value(mold, vals+n, TRUE);
}
}
mold->indent--;
if (indented) New_Indented_Line(mold);
Append_Byte(mold->series, ']');
End_Mold(mold);
Remove_Last(MOLD_LOOP);
}
*/ REBVAL *Get_System(REBCNT i1, REBCNT i2)
/*
** Return a second level object field of the system object.
**
***********************************************************************/
{
REBVAL *obj;
obj = VAL_OBJ_VALUES(ROOT_SYSTEM) + i1;
if (!i2) return obj;
ASSERT1(IS_OBJECT(obj), RP_BAD_OBJ_INDEX);
return Get_Field(VAL_OBJ_FRAME(obj), i2);
}
*/ 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;
}
*/ 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;
}
*/ REBVAL *In_Object(REBSER *base, ...)
/*
** Get value from nested list of objects. List is null terminated.
** Returns object value, else returns 0 if not found.
**
***********************************************************************/
{
REBVAL *obj = 0;
REBCNT n;
va_list args;
va_start(args, base);
while (NZ(n = va_arg(args, REBCNT))) {
if (n >= SERIES_TAIL(base)) return 0;
obj = OFV(base, n);
if (!IS_OBJECT(obj)) return 0;
base = VAL_OBJ_FRAME(obj);
}
va_end(args);
return obj;
}
*/ RL_API int RL_Do_String(int *exit_status, const REBYTE *text, REBCNT flags, RXIARG *result)
/*
** Load a string and evaluate the resulting block.
**
** Returns:
** The datatype of the result if a positive number (or 0 if the
** type has no representation in the "RXT" API). An error code
** if it's a negative number. Two negative numbers are reserved
** for non-error conditions: -1 for halting (e.g. Escape), and
** -2 is reserved for exiting with exit_status set.
**
** Arguments:
** text - A null terminated UTF-8 (or ASCII) string to transcode
** into a block and evaluate.
** flags - set to zero for now
** result - value returned from evaluation, if NULL then result
** will be returned on the top of the stack
**
** Notes:
** This API was from before Rebol's open sourcing and had little
** vetting and few clients. The one client it did have was the
** "sample" console code (which wound up being the "only"
** console code for quite some time).
**
***********************************************************************/
{
REBSER *code;
REBVAL out;
REBOL_STATE state;
const REBVAL *error;
// assumes it can only be run at the topmost level where
// the data stack is completely empty.
assert(DSP == -1);
PUSH_UNHALTABLE_TRAP(&error, &state);
// The first time through the following code 'error' will be NULL, but...
// `raise Error` can longjmp here, so 'error' won't be NULL *if* that happens!
if (error) {
if (VAL_ERR_NUM(error) == RE_HALT)
return -1; // !!! Revisit hardcoded #
// Save error for WHY?
*Get_System(SYS_STATE, STATE_LAST_ERROR) = *error;
if (result)
*result = Value_To_RXI(error);
else
DS_PUSH(error);
return -VAL_ERR_NUM(error);
}
code = Scan_Source(text, LEN_BYTES(text));
PUSH_GUARD_SERIES(code);
// Bind into lib or user spaces?
if (flags) {
// Top words will be added to lib:
Bind_Values_Set_Forward_Shallow(BLK_HEAD(code), Lib_Context);
Bind_Values_Deep(BLK_HEAD(code), Lib_Context);
} else {
REBCNT len;
REBVAL vali;
REBSER *user = VAL_OBJ_FRAME(Get_System(SYS_CONTEXTS, CTX_USER));
len = user->tail;
Bind_Values_All_Deep(BLK_HEAD(code), user);
SET_INTEGER(&vali, len);
Resolve_Context(user, Lib_Context, &vali, FALSE, 0);
}
if (Do_At_Throws(&out, code, 0)) {
DROP_GUARD_SERIES(code);
if (
IS_NATIVE(&out) && (
VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_QUIT_NATIVE)
|| VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_EXIT_NATIVE)
)
) {
CATCH_THROWN(&out, &out);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
*exit_status = Exit_Status_From_Value(&out);
return -2; // Revisit hardcoded #
}
raise Error_No_Catch_For_Throw(&out);
}
DROP_GUARD_SERIES(code);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
if (result)
*result = Value_To_RXI(&out);
else
DS_PUSH(&out);
return Reb_To_RXT[VAL_TYPE(&out)];
}
STOID Mold_Error(REBVAL *value, REB_MOLD *mold, REBFLG molded)
{
ERROR_OBJ *err;
REBVAL *msg; // Error message block
// Protect against recursion. !!!!
if (molded) {
if (VAL_OBJ_FRAME(value) && VAL_ERR_NUM(value) >= RE_NOTE && VAL_ERR_OBJECT(value))
Mold_Object(value, mold);
else {
// Happens if throw or return is molded.
// make error! 0-3
Pre_Mold(value, mold);
Append_Int(mold->series, VAL_ERR_NUM(value));
End_Mold(mold);
}
return;
}
// If it is an unprocessed BREAK, THROW, CONTINUE, RETURN:
if (VAL_ERR_NUM(value) < RE_NOTE || !VAL_ERR_OBJECT(value)) {
VAL_ERR_OBJECT(value) = Make_Error(VAL_ERR_NUM(value), value, 0, 0); // spoofs field
}
err = VAL_ERR_VALUES(value);
// Form: ** <type> Error:
Emit(mold, "** WB", &err->type, RS_ERRS+0);
// Append: error message ARG1, ARG2, etc.
msg = Find_Error_Info(err, 0);
if (msg) {
if (!IS_BLOCK(msg)) Mold_Value(mold, msg, 0);
else {
//start = DSP + 1;
//Reduce_In_Frame(VAL_ERR_OBJECT(value), VAL_BLK_DATA(msg));
//SERIES_TAIL(DS_Series) = DSP + 1;
//Form_Block_Series(DS_Series, start, mold, 0);
Form_Block_Series(VAL_SERIES(msg), 0, mold, VAL_ERR_OBJECT(value));
}
} else
Append_Boot_Str(mold->series, RS_ERRS+1);
Append_Byte(mold->series, '\n');
// Form: ** Where: function
value = &err->where;
if (VAL_TYPE(value) > REB_NONE) {
Append_Boot_Str(mold->series, RS_ERRS+2);
Mold_Value(mold, value, 0);
Append_Byte(mold->series, '\n');
}
// Form: ** Near: location
value = &err->nearest;
if (VAL_TYPE(value) > REB_NONE) {
Append_Boot_Str(mold->series, RS_ERRS+3);
if (IS_STRING(value)) // special case: source file line number
Append_String(mold->series, VAL_SERIES(value), 0, VAL_TAIL(value));
else if (IS_BLOCK(value))
Mold_Simple_Block(mold, VAL_BLK_DATA(value), 60);
Append_Byte(mold->series, '\n');
}
}
*/ static REB_R Loop_Each(struct Reb_Call *call_, REBINT mode)
/*
** Supports these natives (modes):
** 0: foreach
** 1: remove-each
** 2: map
**
***********************************************************************/
{
REBSER *body;
REBVAL *vars;
REBVAL *words;
REBSER *frame;
REBVAL *value;
REBSER *series;
REBSER *out; // output block (for MAP, mode = 2)
REBINT index; // !!!! should these be REBCNT?
REBINT tail;
REBINT windex; // write
REBINT rindex; // read
REBINT err;
REBCNT i;
REBCNT j;
REBVAL *ds;
assert(mode >= 0 && mode < 3);
value = D_ARG(2); // series
if (IS_NONE(value)) return R_NONE;
body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body
SET_OBJECT(D_ARG(1), frame); // keep GC safe
Set_Block(D_ARG(3), body); // keep GC safe
SET_NONE(D_OUT); // Default result to NONE if the loop does not run
// If it's MAP, create result block:
if (mode == 2) {
out = Make_Block(VAL_LEN(value));
SAVE_SERIES(out);
}
// Get series info:
if (ANY_OBJECT(value)) {
series = VAL_OBJ_FRAME(value);
out = FRM_WORD_SERIES(series); // words (the out local reused)
index = 1;
//if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3));
}
else if (IS_MAP(value)) {
series = VAL_SERIES(value);
index = 0;
//if (frame->tail > 3) Trap_Arg_DEAD_END(FRM_WORD(frame, 3));
}
else {
series = VAL_SERIES(value);
index = VAL_INDEX(value);
if (index >= cast(REBINT, SERIES_TAIL(series))) {
if (mode == 1) {
SET_INTEGER(D_OUT, 0);
} else if (mode == 2) {
Set_Block(D_OUT, out);
UNSAVE_SERIES(out);
}
return R_OUT;
}
}
windex = index;
// Iterate over each value in the series block:
while (index < (tail = SERIES_TAIL(series))) {
rindex = index; // remember starting spot
j = 0;
// Set the FOREACH loop variables from the series:
for (i = 1; i < frame->tail; i++) {
vars = FRM_VALUE(frame, i);
words = FRM_WORD(frame, i);
// var spec is WORD
if (IS_WORD(words)) {
if (index < tail) {
if (ANY_BLOCK(value)) {
*vars = *BLK_SKIP(series, index);
}
else if (ANY_OBJECT(value)) {
if (!VAL_GET_EXT(BLK_SKIP(out, index), EXT_WORD_HIDE)) {
// Alternate between word and value parts of object:
if (j == 0) {
Init_Word(vars, REB_WORD, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index);
if (NOT_END(vars+1)) index--; // reset index for the value part
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
Trap_Arg_DEAD_END(words);
j++;
}
else {
// Do not evaluate this iteration
index++;
goto skip_hidden;
}
}
else if (IS_VECTOR(value)) {
Set_Vector_Value(vars, series, index);
}
else if (IS_MAP(value)) {
REBVAL *val = BLK_SKIP(series, index | 1);
if (!IS_NONE(val)) {
if (j == 0) {
*vars = *BLK_SKIP(series, index & ~1);
if (IS_END(vars+1)) index++; // only words
}
else if (j == 1)
*vars = *BLK_SKIP(series, index);
else
Trap_Arg_DEAD_END(words);
j++;
}
else {
index += 2;
goto skip_hidden;
}
}
else { // A string or binary
if (IS_BINARY(value)) {
SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index]));
}
else if (IS_IMAGE(value)) {
Set_Tuple_Pixel(BIN_SKIP(series, index), vars);
}
else {
VAL_SET(vars, REB_CHAR);
VAL_CHAR(vars) = GET_ANY_CHAR(series, index);
}
}
index++;
}
else SET_NONE(vars);
}
// var spec is SET_WORD:
else if (IS_SET_WORD(words)) {
if (ANY_OBJECT(value) || IS_MAP(value)) {
*vars = *value;
} else {
VAL_SET(vars, REB_BLOCK);
VAL_SERIES(vars) = series;
VAL_INDEX(vars) = index;
}
//if (index < tail) index++; // do not increment block.
}
else Trap_Arg_DEAD_END(words);
}
if (index == rindex) index++; //the word block has only set-words: foreach [a:] [1 2 3][]
if (!DO_BLOCK(D_OUT, body, 0)) {
if ((err = Check_Error(D_OUT)) >= 0) {
index = rindex;
break;
}
// else CONTINUE:
if (mode == 1) SET_FALSE(D_OUT); // keep the value (for mode == 1)
} else {
err = 0; // prevent later test against uninitialized value
}
if (mode > 0) {
//if (ANY_OBJECT(value)) Trap_Types_DEAD_END(words, REB_BLOCK, VAL_TYPE(value)); //check not needed
// If FALSE return, copy values to the write location:
if (mode == 1) { // remove-each
if (IS_CONDITIONAL_FALSE(D_OUT)) {
REBCNT wide = SERIES_WIDE(series);
// memory areas may overlap, so use memmove and not memcpy!
memmove(series->data + (windex * wide), series->data + (rindex * wide), (index - rindex) * wide);
windex += index - rindex;
// old: while (rindex < index) *BLK_SKIP(series, windex++) = *BLK_SKIP(series, rindex++);
}
}
else
if (!IS_UNSET(D_OUT)) Append_Value(out, D_OUT); // (mode == 2)
}
skip_hidden: ;
}
// Finish up:
if (mode == 1) {
// Remove hole (updates tail):
if (windex < index) Remove_Series(series, windex, index - windex);
SET_INTEGER(D_OUT, index - windex);
return R_OUT;
}
// If MAP...
if (mode == 2) {
UNSAVE_SERIES(out);
if (err != 2) {
// ...and not BREAK/RETURN:
Set_Block(D_OUT, out);
return R_OUT;
}
}
return R_OUT;
}
*/ void Make_Block_Type(REBFLG make, REBVAL *value, REBVAL *arg)
/*
** Value can be:
** 1. a datatype (e.g. BLOCK!)
** 2. a value (e.g. [...])
**
** Arg can be:
** 1. integer (length of block)
** 2. block (copy it)
** 3. value (convert to a block)
**
***********************************************************************/
{
REBCNT type;
REBCNT len;
REBSER *ser;
// make block! ...
if (IS_DATATYPE(value))
type = VAL_DATATYPE(value);
else // make [...] ....
type = VAL_TYPE(value);
// make block! [1 2 3]
if (ANY_BLOCK(arg)) {
len = VAL_BLK_LEN(arg);
if (len > 0 && type >= REB_PATH && type <= REB_LIT_PATH)
No_Nones(arg);
ser = Copy_Values(VAL_BLK_DATA(arg), len);
goto done;
}
if (IS_STRING(arg)) {
REBCNT index, len = 0;
VAL_SERIES(arg) = Prep_Bin_Str(arg, &index, &len); // (keeps safe)
ser = Scan_Source(VAL_BIN(arg), VAL_LEN(arg));
goto done;
}
if (IS_BINARY(arg)) {
ser = Scan_Source(VAL_BIN_DATA(arg), VAL_LEN(arg));
goto done;
}
if (IS_MAP(arg)) {
ser = Map_To_Block(VAL_SERIES(arg), 0);
goto done;
}
if (ANY_OBJECT(arg)) {
ser = Make_Object_Block(VAL_OBJ_FRAME(arg), 3);
goto done;
}
if (IS_VECTOR(arg)) {
ser = Make_Vector_Block(arg);
goto done;
}
// if (make && IS_NONE(arg)) {
// ser = Make_Block(0);
// goto done;
// }
// to block! typset
if (!make && IS_TYPESET(arg) && type == REB_BLOCK) {
Set_Block(value, Typeset_To_Block(arg));
return;
}
if (make) {
// make block! 10
if (IS_INTEGER(arg) || IS_DECIMAL(arg)) {
len = Int32s(arg, 0);
Set_Series(type, value, Make_Block(len));
return;
}
Trap_Arg(arg);
}
ser = Copy_Values(arg, 1);
done:
Set_Series(type, value, ser);
return;
}
*/ static REBFLG Set_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
REBVAL *spec;
REBVAL *hndl;
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
return Set_Pair(&(gob->offset), val);
case SYM_SIZE:
return Set_Pair(&gob->size, val);
case SYM_IMAGE:
CLR_GOB_OPAQUE(gob);
if (IS_IMAGE(val)) {
SET_GOB_TYPE(gob, GOBT_IMAGE);
GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val);
GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val);
GOB_CONTENT(gob) = VAL_SERIES(val);
// if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
#ifdef HAS_WIDGET_GOB
case SYM_WIDGET:
//printf("WIDGET GOB\n");
SET_GOB_TYPE(gob, GOBT_WIDGET);
SET_GOB_OPAQUE(gob);
GOB_CONTENT(gob) = Make_Block(4); // [handle type spec data]
hndl = Append_Value(GOB_CONTENT(gob));
Append_Value(GOB_CONTENT(gob)); // used to cache type on host's side
spec = Append_Value(GOB_CONTENT(gob));
Append_Value(GOB_CONTENT(gob)); // used to cache result data
SET_HANDLE(hndl, 0, SYM_WIDGET, 0);
if (IS_WORD(val) || IS_LIT_WORD(val)) {
Set_Block(spec, Make_Block(1));
Append_Val(VAL_SERIES(spec), val);
}
else if (IS_BLOCK(val)) {
Set_Block(spec, VAL_SERIES(val));
}
else return FALSE;
break;
#endif // HAS_WIDGET_GOB
case SYM_DRAW:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_DRAW);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_TEXT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_TEXT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_STRING(val)) {
SET_GOB_TYPE(gob, GOBT_STRING);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_EFFECT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_EFFECT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_COLOR:
CLR_GOB_OPAQUE(gob);
if (IS_TUPLE(val)) {
SET_GOB_TYPE(gob, GOBT_COLOR);
Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val);
if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 255)
SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
break;
case SYM_PANE:
if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob));
if (IS_BLOCK(val))
Insert_Gobs(gob, VAL_BLK_DATA(val), 0, VAL_BLK_LEN(val), 0);
else if (IS_GOB(val))
Insert_Gobs(gob, val, 0, 1, 0);
else if (IS_NONE(val))
gob->pane = 0;
else
return FALSE;
break;
case SYM_ALPHA:
GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255);
break;
case SYM_DATA:
#ifdef HAS_WIDGET_GOB
if (GOB_TYPE(gob) == GOBT_WIDGET) {
OS_SET_WIDGET_DATA(gob, val);
} else {
#endif
SET_GOB_DTYPE(gob, GOBD_NONE);
if (IS_OBJECT(val)) {
SET_GOB_DTYPE(gob, GOBD_OBJECT);
SET_GOB_DATA(gob, VAL_OBJ_FRAME(val));
}
else if (IS_BLOCK(val)) {
SET_GOB_DTYPE(gob, GOBD_BLOCK);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_STRING(val)) {
SET_GOB_DTYPE(gob, GOBD_STRING);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_BINARY(val)) {
SET_GOB_DTYPE(gob, GOBD_BINARY);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_INTEGER(val)) {
SET_GOB_DTYPE(gob, GOBD_INTEGER);
SET_GOB_DATA(gob, (void*)(REBIPT)VAL_INT64(val));
}
else if (IS_NONE(val))
SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
#ifdef HAS_WIDGET_GOB
}
#endif
break;
case SYM_FLAGS:
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
else if (IS_BLOCK(val)) {
gob->flags = 0;
for (val = VAL_BLK(val); NOT_END(val); val++) {
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
}
}
break;
case SYM_OWNER:
if (IS_GOB(val))
GOB_TMP_OWNER(gob) = VAL_GOB(val);
else
return FALSE;
break;
default:
return FALSE;
}
return TRUE;
}
*/ REBSER *Make_Std_Object(REBCNT index)
/*
***********************************************************************/
{
return CLONE_OBJECT(VAL_OBJ_FRAME(Get_System(SYS_STANDARD, index)));
}
*/ REBCNT Get_Part_Length(REBVAL *bval, REBVAL *eval)
/*
** Determine the length of a /PART value.
** If /PART value is an integer just use it.
** If it is a series and it is the same series as the first,
** use the difference between the two indices.
**
** If the length ends up negative, back up the index as much
** as possible. If backed up over the head, adjust the length.
**
** Note: This one does not handle list datatypes.
**
***********************************************************************/
{
REBINT len;
REBCNT tail;
if (IS_INTEGER(eval) || IS_DECIMAL(eval)) {
len = Int32(eval);
if (IS_SCALAR(bval) && VAL_TYPE(bval) != REB_PORT)
Trap1(RE_INVALID_PART, bval);
}
else if (
(
// IF normal series and self referencing:
VAL_TYPE(eval) >= REB_STRING &&
VAL_TYPE(eval) <= REB_BLOCK &&
VAL_TYPE(bval) == VAL_TYPE(eval) &&
VAL_SERIES(bval) == VAL_SERIES(eval)
) || (
// OR IF it is a port:
IS_PORT(bval) && IS_PORT(eval) &&
VAL_OBJ_FRAME(bval) == VAL_OBJ_FRAME(eval)
)
)
len = (REBINT)VAL_INDEX(eval) - (REBINT)VAL_INDEX(bval);
else
Trap1(RE_INVALID_PART, eval);
/* !!!!
if (IS_PORT(bval)) {
PORT_STATE_OBJ *port;
port = VAL_PORT(&VAL_PSP(bval)->state);
if (PORT_FLAG(port) & PF_DIRECT)
tail = 0x7fffffff;
else
tail = PORT_TAIL(VAL_PORT(&VAL_PSP(bval)->state));
}
else
*/ tail = VAL_TAIL(bval);
if (len < 0) {
len = -len;
if (len > (REBINT)VAL_INDEX(bval))
len = (REBINT)VAL_INDEX(bval);
VAL_INDEX(bval) -= (REBCNT)len;
}
else if (!IS_INTEGER(eval) && (len + VAL_INDEX(bval)) > tail)
len = (REBINT)(tail - VAL_INDEX(bval));
return (REBCNT)len;
}
*/ static REBFLG Set_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
/*
***********************************************************************/
{
switch (VAL_WORD_CANON(word)) {
case SYM_OFFSET:
return Set_Pair(&(gob->offset), val);
case SYM_SIZE:
return Set_Pair(&gob->size, val);
case SYM_IMAGE:
CLR_GOB_OPAQUE(gob);
if (IS_IMAGE(val)) {
SET_GOB_TYPE(gob, GOBT_IMAGE);
GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val);
GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val);
GOB_CONTENT(gob) = VAL_SERIES(val);
// if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_DRAW:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_DRAW);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_TEXT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_TEXT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_STRING(val)) {
SET_GOB_TYPE(gob, GOBT_STRING);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_EFFECT:
CLR_GOB_OPAQUE(gob);
if (IS_BLOCK(val)) {
SET_GOB_TYPE(gob, GOBT_EFFECT);
GOB_CONTENT(gob) = VAL_SERIES(val);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_COLOR:
CLR_GOB_OPAQUE(gob);
if (IS_TUPLE(val)) {
SET_GOB_TYPE(gob, GOBT_COLOR);
Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val);
if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 0)
SET_GOB_OPAQUE(gob);
}
else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
break;
case SYM_PANE:
if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob));
if (IS_BLOCK(val))
Insert_Gobs(gob, VAL_BLK_DATA(val), 0, VAL_BLK_LEN(val), 0);
else if (IS_GOB(val))
Insert_Gobs(gob, val, 0, 1, 0);
else if (IS_NONE(val))
gob->pane = 0;
else
return FALSE;
break;
case SYM_ALPHA:
GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255);
break;
case SYM_DATA:
SET_GOB_DTYPE(gob, GOBD_NONE);
if (IS_OBJECT(val)) {
SET_GOB_DTYPE(gob, GOBD_OBJECT);
SET_GOB_DATA(gob, VAL_OBJ_FRAME(val));
}
else if (IS_BLOCK(val)) {
SET_GOB_DTYPE(gob, GOBD_BLOCK);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_STRING(val)) {
SET_GOB_DTYPE(gob, GOBD_STRING);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_BINARY(val)) {
SET_GOB_DTYPE(gob, GOBD_BINARY);
SET_GOB_DATA(gob, VAL_SERIES(val));
}
else if (IS_INTEGER(val)) {
SET_GOB_DTYPE(gob, GOBD_INTEGER);
SET_GOB_DATA(gob, (void*)(REBIPT)VAL_INT64(val));
}
else if (IS_NONE(val))
SET_GOB_TYPE(gob, GOBT_NONE);
else return FALSE;
break;
case SYM_FLAGS:
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
else if (IS_BLOCK(val)) {
gob->flags = 0;
for (val = VAL_BLK(val); NOT_END(val); val++) {
if (IS_WORD(val)) Set_Gob_Flag(gob, val);
}
}
break;
case SYM_OWNER:
if (IS_GOB(val))
GOB_TMP_OWNER(gob) = VAL_GOB(val);
else
return FALSE;
break;
default:
return FALSE;
}
return TRUE;
}