*/ void Dump_Stack(REBINT dsf, REBINT dsp)
/*
***********************************************************************/
{
REBINT n;
REBINT m;
REBVAL *args;
if (dsf == 0) {
dsf = DSF;
dsp = DSP;
}
m = dsp - dsf - DSF_SIZE;
Debug_Fmt(BOOT_STR(RS_STACK, 1), dsp, Get_Word_Name(DSF_WORD(dsf)), m, Get_Type_Name(DSF_FUNC(dsf)));
if (dsf > 0) {
if (ANY_FUNC(DSF_FUNC(dsf))) {
args = BLK_HEAD(VAL_FUNC_ARGS(DSF_FUNC(dsf)));
m = SERIES_TAIL(VAL_FUNC_ARGS(DSF_FUNC(dsf)));
for (n = 1; n < m; n++)
Debug_Fmt("\t%s: %72r", Get_Word_Name(args+n), DSF_ARGS(dsf, n));
}
//Debug_Fmt(Str_Stack[2], PRIOR_DSF(dsf));
if (PRIOR_DSF(dsf) > 0) Dump_Stack(PRIOR_DSF(dsf), dsf-1);
}
//for (n = 1; n <= 2; n++) {
// Debug_Fmt(" ARG%d: %s %r", n, Get_Type_Name(DSF_ARGS(dsf, n)), DSF_ARGS(dsf, n));
//}
}
*/ 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;
}
*/ static void Sort_Block(REBVAL *block, REBFLG ccase, REBVAL *skipv, REBVAL *compv, REBVAL *part, REBFLG all, REBFLG rev)
/*
** series [series!]
** /case {Case sensitive sort}
** /skip {Treat the series as records of fixed size}
** size [integer!] {Size of each record}
** /compare {Comparator offset, block or function}
** comparator [integer! block! function!]
** /part {Sort only part of a series}
** length [number! series!] {Length of series to sort}
** /all {Compare all fields}
** /reverse {Reverse sort order}
**
***********************************************************************/
{
REBCNT len;
REBCNT skip = 1;
REBCNT size = sizeof(REBVAL);
// int (*sfunc)(const void *v1, const void *v2);
sort_flags.cased = ccase;
sort_flags.reverse = rev;
sort_flags.compare = 0;
sort_flags.offset = 0;
if (IS_INTEGER(compv)) sort_flags.offset = Int32(compv)-1;
if (ANY_FUNC(compv)) sort_flags.compare = compv;
// Determine length of sort:
len = Partial1(block, part);
if (len <= 1) return;
// Skip factor:
if (!IS_NONE(skipv)) {
skip = Get_Num_Arg(skipv);
if (skip <= 0 || len % skip != 0 || skip > len)
Trap_Range(skipv);
}
// Use fast quicksort library function:
if (skip > 1) len /= skip, size *= skip;
if (sort_flags.compare)
qsort((void *)VAL_BLK_DATA(block), len, size, Compare_Call);
else
qsort((void *)VAL_BLK_DATA(block), len, size, Compare_Val);
}
x*/ REBRXT Do_Callback(REBSER *obj, u32 name, RXIARG *rxis, RXIARG *result)
/*
** Given an object and a word id, call a REBOL function.
** The arguments are converted from extension format directly
** to the data stack. The result is passed back in ext format,
** with the datatype returned or zero if there was a problem.
**
***********************************************************************/
{
REBVAL *val;
struct Reb_Call *call;
REBCNT len;
REBCNT n;
REBVAL label;
REBVAL out;
// Find word in object, verify it is a function.
if (!(val = Find_Word_Value(obj, name))) {
SET_EXT_ERROR(result, RXE_NO_WORD);
return 0;
}
if (!ANY_FUNC(val)) {
SET_EXT_ERROR(result, RXE_NOT_FUNC);
return 0;
}
// Create stack frame (use prior stack frame for location info):
SET_TRASH_SAFE(&out); // OUT slot for function eval result
Val_Init_Word_Unbound(&label, REB_WORD, name);
call = Make_Call(
&out,
VAL_SERIES(DSF_WHERE(PRIOR_DSF(DSF))),
VAL_INDEX(DSF_WHERE(PRIOR_DSF(DSF))),
&label,
val
);
obj = VAL_FUNC_PARAMLIST(val); // func words
len = SERIES_TAIL(obj)-1; // number of args (may include locals)
// Push args. Too short or too long arg frames are handled W/O error.
// Note that refinements args can be set to anything.
for (n = 1; n <= len; n++) {
REBVAL *arg = DSF_ARG(call, n);
if (n <= RXI_COUNT(rxis))
RXI_To_Value(arg, rxis[n], RXI_TYPE(rxis, n));
else
SET_NONE(arg);
// Check type for word at the given offset:
if (!TYPE_CHECK(BLK_SKIP(obj, n), VAL_TYPE(arg))) {
result->i2.int32b = n;
SET_EXT_ERROR(result, RXE_BAD_ARGS);
Free_Call(call);
return 0;
}
}
// Evaluate the function:
if (Dispatch_Call_Throws(call)) {
// !!! Does this need handling such that there is a way for the thrown
// value to "bubble up" out of the callback, or is an error sufficient?
fail (Error_No_Catch_For_Throw(DSF_OUT(call)));
}
// Return resulting value from output
*result = Value_To_RXI(&out);
return Reb_To_RXT[VAL_TYPE(&out)];
}
*/ int Do_Port_Action(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
** Call a PORT actor (action) value. Search PORT actor
** first. If not found, search the PORT scheme actor.
**
** NOTE: stack must already be setup correctly for action, and
** the caller must cleanup the stack.
**
***********************************************************************/
{
REBVAL *actor;
REBCNT n = 0;
assert(action < A_MAX_ACTION);
// Verify valid port (all of these must be false):
if (
// Must be = or larger than std port:
(SERIES_TAIL(port) < STD_PORT_MAX) ||
// Must be an object series:
!IS_FRAME(BLK_HEAD(port)) ||
// Must have a spec object:
!IS_OBJECT(BLK_SKIP(port, STD_PORT_SPEC))
) {
raise Error_0(RE_INVALID_PORT);
}
// Get actor for port, if it has one:
actor = BLK_SKIP(port, STD_PORT_ACTOR);
if (IS_NONE(actor)) return R_NONE;
// If actor is a native function:
if (IS_NATIVE(actor))
return cast(REBPAF, VAL_FUNC_CODE(actor))(call_, port, action);
// actor must be an object:
if (!IS_OBJECT(actor)) raise Error_0(RE_INVALID_ACTOR);
// Dispatch object function:
n = Find_Action(actor, action);
actor = Obj_Value(actor, n);
if (!n || !actor || !ANY_FUNC(actor))
raise Error_1(RE_NO_PORT_ACTION, Get_Action_Word(action));
if (Redo_Func_Throws(actor)) {
// No special handling needed, as we are just going to return
// the output value in D_OUT anyway.
}
return R_OUT;
// If not in PORT actor, use the SCHEME actor:
#ifdef no_longer_used
if (n == 0) {
actor = Obj_Value(scheme, STD_SCHEME_actor);
if (!actor) goto err;
if (IS_NATIVE(actor)) goto fun;
if (!IS_OBJECT(actor)) goto err; //vTrap_Expect(value, STD_PORT_actor, REB_OBJECT);
n = Find_Action(actor, action);
if (n == 0) goto err;
}
#endif
}
x*/ int Do_Callback(REBSER *obj, u32 name, RXIARG *args, RXIARG *result)
/*
** Given an object and a word id, call a REBOL function.
** The arguments are converted from extension format directly
** to the data stack. The result is passed back in ext format,
** with the datatype returned or zero if there was a problem.
**
***********************************************************************/
{
REBVAL *val;
REBCNT dsf;
REBCNT len;
REBCNT n;
REBCNT dsp = DSP; // to restore stack on errors
// Find word in object, verify it is a function.
if (!(val = Find_Word_Value(obj, name))) {
SET_EXT_ERROR(result, RXE_NO_WORD);
return 0;
}
if (!ANY_FUNC(val)) {
SET_EXT_ERROR(result, RXE_NOT_FUNC);
return 0;
}
// Get block and index from prior function stack frame:
dsf = PRIOR_DSF(DSF);
// Create stack frame (use prior stack frame for location info):
dsf = Push_Func(0, VAL_SERIES(DSF_BACK(dsf)), VAL_INDEX(DSF_BACK(dsf)), name, val);
val = DSF_FUNC(dsf); // for safety from GC
obj = VAL_FUNC_WORDS(val); // func words
len = SERIES_TAIL(obj)-1; // number of args (may include locals)
// Push args. Too short or too long arg frames are handled W/O error.
// Note that refinements args can be set to anything.
for (n = 1; n <= len && n <= RXI_COUNT(args); n++) {
DS_SKIP;
RXI_To_Value(DS_TOP, args[n], RXI_TYPE(args, n));
// Check type for word at the given offset:
if (!TYPE_CHECK(BLK_SKIP(obj, n), VAL_TYPE(DS_TOP))) {
result->int32b = n;
SET_EXT_ERROR(result, RXE_BAD_ARGS);
DSP = dsp;
return 0;
}
}
// Fill with NONE if necessary:
for (; n <= len; n++) {
DS_SKIP;
SET_NONE(DS_TOP);
if (!TYPE_CHECK(BLK_SKIP(obj, n), VAL_TYPE(DS_TOP))) {
result->int32b = n;
SET_EXT_ERROR(result, RXE_BAD_ARGS);
DSP = dsp;
return 0;
}
}
// Evaluate the function:
DSF = dsf;
Func_Dispatch[VAL_TYPE(val) - REB_NATIVE](val);
DSF = PRIOR_DSF(dsf);
DSP = dsf-1;
// Return resulting value from TOS1 (volatile location):
*result = Value_To_RXI(DS_VALUE(dsf));
return Reb_To_RXT[VAL_TYPE(DS_VALUE(dsf))];
}