//
// Map_To_Block: C
//
// mapser = series of the map
// what: -1 - words, +1 - values, 0 -both
//
REBSER *Map_To_Block(REBSER *mapser, REBINT what)
{
REBVAL *val;
REBCNT cnt = 0;
REBSER *blk;
REBVAL *out;
// Count number of set entries:
for (val = BLK_HEAD(mapser); NOT_END(val) && NOT_END(val+1); val += 2) {
if (!IS_NONE(val+1)) cnt++; // must have non-none value
}
// Copy entries to new block:
blk = Make_Array(cnt * ((what == 0) ? 2 : 1));
out = BLK_HEAD(blk);
for (val = BLK_HEAD(mapser); NOT_END(val) && NOT_END(val+1); val += 2) {
if (!IS_NONE(val+1)) {
if (what <= 0) *out++ = val[0];
if (what >= 0) *out++ = val[1];
}
}
SET_END(out);
blk->tail = out - BLK_HEAD(blk);
return blk;
}
*/ static void Sort_String(REBVAL *string, REBFLG ccase, REBVAL *skipv, REBVAL *compv, REBVAL *part, REBFLG all, REBFLG rev)
/*
***********************************************************************/
{
REBCNT len;
REBCNT skip = 1;
REBCNT size = 1;
int (*sfunc)(const void *v1, const void *v2);
// Determine length of sort:
len = Partial(string, 0, part, 0);
if (len <= 1) return;
// Skip factor:
if (!IS_NONE(skipv)) {
skip = Get_Num_Arg(skipv);
if (skip <= 0 || len % skip != 0 || skip > len)
Trap_Arg(skipv);
}
// Use fast quicksort library function:
if (skip > 1) len /= skip, size *= skip;
sfunc = rev ? Compare_Chr_Rev : Compare_Chr;
//!!uni - needs to compare wide chars too
qsort((void *)VAL_DATA(string), len, size * SERIES_WIDE(VAL_SERIES(string)), sfunc);
}
*/ static void replace_with(REBSER *ser, REBCNT index, REBCNT tail, REBVAL *with)
/*
** Replace whitespace chars that match WITH string.
**
** Resulting string is always smaller than it was to start.
**
***********************************************************************/
{
#define MAX_WITH 32
REBCNT wlen;
REBUNI with_chars[MAX_WITH]; // chars to be trimmed
REBUNI *up = with_chars;
REBYTE *bp;
REBCNT n;
REBUNI uc;
// Setup WITH array from arg or the default:
n = 0;
if (IS_NONE(with)) {
bp = "\n \r\t";
wlen = n = 4;
}
else if (IS_CHAR(with)) {
wlen = 1;
*up++ = VAL_CHAR(with);
}
else if (IS_INTEGER(with)) {
wlen = 1;
*up++ = Int32s(with, 0);
}
else if (ANY_BINSTR(with)) {
n = VAL_LEN(with);
if (n >= MAX_WITH) n = MAX_WITH-1;
wlen = n;
if (VAL_BYTE_SIZE(with)) {
bp = VAL_BIN_DATA(with);
} else {
memcpy(up, VAL_UNI_DATA(with), n * sizeof(REBUNI));
n = 0;
}
}
for (; n > 0; n--) *up++ = (REBUNI)*bp++;
// Remove all occurances of chars found in WITH string:
for (n = index; index < tail; index++) {
uc = GET_ANY_CHAR(ser, index);
if (!find_in_uni(with_chars, wlen, uc)) {
SET_ANY_CHAR(ser, n, uc);
n++;
}
}
SET_ANY_CHAR(ser, n, 0);
SERIES_TAIL(ser) = n;
}
*/ REBSER *Map_To_Object(REBSER *mapser)
/*
***********************************************************************/
{
REBVAL *val;
REBCNT cnt = 0;
REBSER *frame;
REBVAL *key;
REBVAL *mval;
// Count number of set entries:
for (mval = BLK_HEAD(mapser); NOT_END(mval) && NOT_END(mval+1); mval += 2) {
if (ANY_WORD(mval) && !IS_NONE(mval+1)) cnt++;
}
// See Make_Frame() - cannot use it directly because no Collect_Words
frame = Make_Frame(cnt, TRUE);
key = FRM_KEY(frame, 1);
val = FRM_VALUE(frame, 1);
for (mval = BLK_HEAD(mapser); NOT_END(mval) && NOT_END(mval+1); mval += 2) {
if (ANY_WORD(mval) && !IS_NONE(mval+1)) {
// !!! Used to leave SET_WORD typed values here... but why?
// (Objects did not make use of the set-word vs. other distinctions
// that function specs did.)
Val_Init_Typeset(
key,
// all types except END or UNSET
~((FLAGIT_64(REB_END) | FLAGIT_64(REB_UNSET))),
VAL_WORD_SYM(mval)
);
key++;
*val++ = mval[1];
}
}
SET_END(key);
SET_END(val);
FRM_KEYLIST(frame)->tail = frame->tail = cnt + 1;
return frame;
}
*/ REBFLG Get_Logic_Arg(REBVAL *arg)
/*
***********************************************************************/
{
if (IS_NONE(arg)) return 0;
if (IS_INTEGER(arg)) return (VAL_INT64(arg) != 0);
if (IS_LOGIC(arg)) return (VAL_LOGIC(arg) != 0);
if (IS_DECIMAL(arg) || IS_PERCENT(arg)) return (VAL_DECIMAL(arg) != 0.0);
Trap_Arg(arg);
DEAD_END;
}
//
// Length_Map: C
//
REBINT Length_Map(REBSER *series)
{
REBCNT n, c = 0;
REBVAL *v = BLK_HEAD(series);
for (n = 0; n < series->tail; n += 2, v += 2) {
if (!IS_NONE(v+1)) c++; // must have non-none value
}
return c;
}
*/ REBSER *Map_To_Object(REBSER *mapser)
/*
***********************************************************************/
{
REBVAL *val;
REBCNT cnt = 0;
REBSER *frame;
REBVAL *word;
REBVAL *mval;
// Count number of set entries:
for (mval = BLK_HEAD(mapser); NOT_END(mval) && NOT_END(mval+1); mval += 2) {
if (ANY_WORD(mval) && !IS_NONE(mval+1)) cnt++;
}
// See Make_Frame() - cannot use it directly because no Collect_Words
frame = Make_Frame(cnt, TRUE);
word = FRM_WORD(frame, 1);
val = FRM_VALUE(frame, 1);
for (mval = BLK_HEAD(mapser); NOT_END(mval) && NOT_END(mval+1); mval += 2) {
if (ANY_WORD(mval) && !IS_NONE(mval+1)) {
Init_Unword(
word,
REB_SET_WORD,
VAL_WORD_SYM(mval),
// all types except END or UNSET
~((TYPESET(REB_END) | TYPESET(REB_UNSET)))
);
word++;
*val++ = mval[1];
}
}
SET_END(word);
SET_END(val);
FRM_WORD_SERIES(frame)->tail = frame->tail = cnt + 1;
return frame;
}
*/ void Catch_Error(REBVAL *value)
/*
** Gets the current error and stores it as a value.
** Normally the value is on the stack and is returned.
**
***********************************************************************/
{
if (IS_NONE(TASK_THIS_ERROR)) Crash(RP_ERROR_CATCH);
*value = *TASK_THIS_ERROR;
// Print("CE: %r", value);
SET_NONE(TASK_THIS_ERROR);
//!!! Reset or ENABLE_GC;
}
*/ REBVAL *Make_Module(REBVAL *spec)
/*
** Create a module from a spec and an init block.
** Call the Make_Module function in the system/intrinsic object.
**
***********************************************************************/
{
REBVAL *value;
value = Do_Sys_Func(SYS_CTX_MAKE_MODULE_P, spec, 0); // volatile
if (IS_NONE(value)) Trap1(RE_INVALID_SPEC, spec);
return value;
}
*/ void Trap_Port(REBCNT errnum, REBSER *port, REBINT err_code)
/*
***********************************************************************/
{
REBVAL *spec = OFV(port, STD_PORT_SPEC);
REBVAL *val;
if (!IS_OBJECT(spec)) Trap0(RE_INVALID_PORT);
val = Get_Object(spec, STD_PORT_SPEC_HEAD_REF); // most informative
if (IS_NONE(val)) val = Get_Object(spec, STD_PORT_SPEC_HEAD_TITLE);
DS_PUSH_INTEGER(err_code);
Trap2(errnum, val, DS_TOP);
}
*/ void Make_Port(REBVAL *out, const REBVAL *spec)
/*
** Create a new port. This is done by calling the MAKE_PORT
** function stored in the system/intrinsic object.
**
***********************************************************************/
{
if (Do_Sys_Func_Throws(out, SYS_CTX_MAKE_PORT_P, spec, 0)) {
// Gave back an unhandled RETURN, BREAK, CONTINUE, etc...
raise Error_No_Catch_For_Throw(out);
}
// !!! Shouldn't this be testing for !IS_PORT( ) ?
if (IS_NONE(out)) raise Error_1(RE_INVALID_SPEC, spec);
}
*/ void Make_Module(REBVAL *out, const REBVAL *spec)
/*
** Create a module from a spec and an init block.
** Call the Make_Module function in the system/intrinsic object.
**
***********************************************************************/
{
if (Do_Sys_Func_Throws(out, SYS_CTX_MAKE_MODULE_P, spec, 0)) {
// Gave back an unhandled RETURN, BREAK, CONTINUE, etc...
raise Error_No_Catch_For_Throw(out);
}
// !!! Shouldn't this be testing for !IS_MODULE(out)?
if (IS_NONE(out)) raise Error_1(RE_INVALID_SPEC, spec);
}
*/ 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);
}
static int Node__delete(Node *self)
{
Node *utmost, *n_self, *p = self->parent;
int bf;
PyObject *ut_key, *s_key;
if ((NOT_NONE(self->left) && NOT_NONE(self->right)) || IS_NONE(p)) {
// Both children exist or root node
if (NOT_NONE(self->left))
// Left child present or both children present
utmost = Node__rightmost(self->left);
else if (NOT_NONE(self->right))
// Only right child present, root node
utmost = Node__leftmost(self->right);
else {
// No children, root node
PyErr_SetString(PyExc_RuntimeError, "can't remove the last node");
return -1;
}
ut_key = utmost->key;
//printf("ut_key = %li\n", PyInt_AS_LONG(ut_key));
s_key = self->key;
Py_INCREF(ut_key);
Node__delete(utmost);
n_self = Node__search(self, s_key);
Py_DECREF(n_self->key);
n_self->key = ut_key;
} else {
// Non-root node with only one child
bf = Node__get_child_place(p, self);
if (NOT_NONE(self->left))
// Only left child exists
Node__connect_to_parent(self->left, p);
else if (NOT_NONE(self->right))
// Only right child exists
Node__connect_to_parent(self->right, p);
else // No children exist, node is not root
Node__disconnect(p, self);
Node__update_bf_on_decrease(p, -bf, 0);
}
return 0;
}
*/ REBINT PD_Tuple(REBPVS *pvs)
/*
** Implements PATH and SET_PATH for tuple.
** Sets DS_TOP if found. Always returns 0.
**
***********************************************************************/
{
REBVAL *val;
REBINT n;
REBINT i;
REBYTE *dat;
REBINT len;
dat = VAL_TUPLE(pvs->value);
len = VAL_TUPLE_LEN(pvs->value);
if (len < 3) len = 3;
n = Get_Num_Arg(pvs->select);
if (NZ(val = pvs->setval)) {
if (n <= 0 || n > MAX_TUPLE) return PE_BAD_SELECT;
if (IS_INTEGER(val) || IS_DECIMAL(val)) i = Int32(val);
else if (IS_NONE(val)) {
n--;
CLEAR(dat+n, MAX_TUPLE-n);
VAL_TUPLE_LEN(pvs->value) = n;
return PE_OK;
}
else return PE_BAD_SET;
if (i < 0) i = 0;
else if (i > 255) i = 255;
dat[n-1] = i;
if (n > len) VAL_TUPLE_LEN(pvs->value) = n;
return PE_OK;
} else {
if (n > 0 && n <= len) {
SET_INTEGER(pvs->store, dat[n-1]);
return PE_USE;
}
else return PE_NONE;
}
}
//
// PD_Map: C
//
REBINT PD_Map(REBPVS *pvs)
{
REBVAL *data = pvs->value;
REBVAL *val = 0;
REBINT n = 0;
if (IS_END(pvs->path+1)) val = pvs->setval;
if (IS_NONE(pvs->select)) return PE_NONE;
if (!ANY_WORD(pvs->select) && !ANY_BINSTR(pvs->select) &&
!IS_INTEGER(pvs->select) && !IS_CHAR(pvs->select))
return PE_BAD_SELECT;
n = Find_Entry(VAL_SERIES(data), pvs->select, val);
if (!n) return PE_NONE;
TRAP_PROTECT(VAL_SERIES(data));
pvs->value = VAL_BLK_SKIP(data, ((n-1)*2)+1);
return PE_OK;
}
*/ REBINT Partial1(REBVAL *sval, REBVAL *lval)
/*
** Process the /part (or /skip) and other length modifying
** arguments.
**
***********************************************************************/
{
REBI64 len;
REBINT maxlen;
REBINT is_ser = ANY_SERIES(sval);
// If lval = NONE, use the current len of the target value:
if (IS_NONE(lval)) {
if (!is_ser) return 1;
if (VAL_INDEX(sval) >= VAL_TAIL(sval)) return 0;
return (VAL_TAIL(sval) - VAL_INDEX(sval));
}
if (IS_INTEGER(lval) || IS_DECIMAL(lval)) len = Int32(lval);
else {
if (is_ser && VAL_TYPE(sval) == VAL_TYPE(lval) && VAL_SERIES(sval) == VAL_SERIES(lval))
len = (REBINT)VAL_INDEX(lval) - (REBINT)VAL_INDEX(sval);
else
Trap1(RE_INVALID_PART, lval);
}
if (is_ser) {
// Restrict length to the size available:
if (len >= 0) {
maxlen = (REBINT)VAL_LEN(sval);
if (len > maxlen) len = maxlen;
} else {
len = -len;
if (len > (REBINT)VAL_INDEX(sval)) len = (REBINT)VAL_INDEX(sval);
VAL_INDEX(sval) -= (REBCNT)len;
}
}
return (REBINT)len;
}
*/ static int Find_Command(REBSER *dialect, REBVAL *word)
/*
** Given a word, check to see if it is in the dialect object.
** If so, return its index. If not, return 0.
**
***********************************************************************/
{
REBINT n;
if (dialect == VAL_WORD_FRAME(word)) n = VAL_WORD_INDEX(word);
else {
if (NZ(n = Find_Word_Index(dialect, VAL_WORD_SYM(word), FALSE))) {
VAL_WORD_FRAME(word) = dialect;
VAL_WORD_INDEX(word) = n;
}
else return 0;
}
// If keyword (not command) return negated index:
if (IS_NONE(FRM_VALUES(dialect) + n)) return -n;
return n;
}
STOID Mold_Map(REBVAL *value, REB_MOLD *mold, REBFLG molded)
{
REBSER *mapser = VAL_SERIES(value);
REBVAL *val;
// Prevent endless mold loop:
if (Find_Same_Block(MOLD_LOOP, value) > 0) {
Append_Bytes(mold->series, "...]");
return;
}
Append_Val(MOLD_LOOP, value);
if (molded) {
Pre_Mold(value, mold);
Append_Byte(mold->series, '[');
}
// Mold all non-none entries
mold->indent++;
for (val = BLK_HEAD(mapser); NOT_END(val) && NOT_END(val+1); val += 2) {
if (!IS_NONE(val+1)) {
if (molded) New_Indented_Line(mold);
Emit(mold, "V V", val, val+1);
if (!molded) Append_Byte(mold->series, '\n');
}
}
mold->indent--;
if (molded) {
New_Indented_Line(mold);
Append_Byte(mold->series, ']');
}
End_Mold(mold);
Remove_Last(MOLD_LOOP);
}
//
// Frame_For_Stack_Level: C
//
// Level can be an UNSET!, an INTEGER!, an ANY-FUNCTION!, or a FRAME!. If
// level is UNSET! then it means give whatever the first call found is.
//
// Returns NULL if the given level number does not correspond to a running
// function on the stack.
//
// Can optionally give back the index number of the stack level (counting
// where the most recently pushed stack level is the lowest #)
//
// !!! Unfortunate repetition of logic inside of BACKTRACE; find a way to
// unify the logic for omitting things like breakpoint frames, or either
// considering pending frames or not...
//
struct Reb_Frame *Frame_For_Stack_Level(
REBCNT *number_out,
const REBVAL *level,
REBOOL skip_current
) {
struct Reb_Frame *frame = FS_TOP;
REBOOL first = TRUE;
REBINT num = 0;
if (IS_INTEGER(level)) {
if (VAL_INT32(level) < 0) {
//
// !!! fail() here, or just return NULL?
//
return NULL;
}
}
// We may need to skip some number of frames, if there have been stack
// levels added since the numeric reference point that "level" was
// supposed to refer to has changed. For now that's only allowed to
// be one level, because it's rather fuzzy which stack levels to
// omit otherwise (pending? parens?)
//
if (skip_current)
frame = frame->prior;
for (; frame != NULL; frame = frame->prior) {
if (frame->mode != CALL_MODE_FUNCTION) {
//
// Don't consider pending calls, or GROUP!, or any non-invoked
// function as a candidate to target.
//
// !!! The inability to target a GROUP! by number is an artifact
// of implementation, in that there's no hook in Do_Core() at
// the point of group evaluation to process the return. The
// matter is different with a pending function call, because its
// arguments are only partially processed--hence something
// like a RESUME/AT or an EXIT/FROM would not know which array
// index to pick up running from.
//
continue;
}
if (first) {
if (
IS_FUNCTION_AND(FUNC_VALUE(frame->func), FUNC_CLASS_NATIVE)
&& (
FUNC_CODE(frame->func) == &N_pause
|| FUNC_CODE(frame->func) == N_breakpoint
)
) {
// this is considered the "0". Return it only if 0 was requested
// specifically (you don't "count down to it");
//
if (IS_INTEGER(level) && num == VAL_INT32(level))
goto return_maybe_set_number_out;
else {
first = FALSE;
continue;
}
}
else {
++num; // bump up from 0
}
}
if (IS_INTEGER(level) && num == VAL_INT32(level))
goto return_maybe_set_number_out;
first = FALSE;
if (frame->mode != CALL_MODE_FUNCTION) {
//
// Pending frames don't get numbered
//
continue;
}
if (IS_UNSET(level) || IS_NONE(level)) {
//
// Take first actual frame if unset or none
//
goto return_maybe_set_number_out;
}
else if (IS_INTEGER(level)) {
++num;
if (num == VAL_INT32(level))
goto return_maybe_set_number_out;
}
else if (IS_FRAME(level)) {
if (
(frame->flags & DO_FLAG_FRAME_CONTEXT)
&& frame->data.context == VAL_CONTEXT(level)
) {
goto return_maybe_set_number_out;
}
}
else {
assert(IS_FUNCTION(level));
if (VAL_FUNC(level) == frame->func)
goto return_maybe_set_number_out;
}
}
// Didn't find it...
//
return NULL;
return_maybe_set_number_out:
if (number_out)
*number_out = num;
return frame;
}
//
// Transport_Actor: C
//
static REB_R Transport_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action, enum Transport_Types proto)
{
REBREQ *sock; // IO request
REBVAL *spec; // port spec
REBVAL *arg; // action argument value
REBVAL *val; // e.g. port number value
REBINT result; // IO result
REBCNT refs; // refinement argument flags
REBCNT len; // generic length
REBSER *ser; // simplifier
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
arg = DS_ARGC > 1 ? D_ARG(2) : NULL;
sock = cast(REBREQ*, Use_Port_State(port, RDI_NET, sizeof(*sock)));
if (proto == TRANSPORT_UDP) {
SET_FLAG(sock->modes, RST_UDP);
}
//Debug_Fmt("Sock: %x", sock);
spec = OFV(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) fail (Error(RE_INVALID_PORT));
// sock->timeout = 4000; // where does this go? !!!
// HOW TO PREVENT OVERWRITE DURING BUSY OPERATION!!!
// Should it just ignore it or cause an error?
// Actions for an unopened socket:
if (!IS_OPEN(sock)) {
switch (action) { // Ordered by frequency
case A_OPEN:
arg = Obj_Value(spec, STD_PORT_SPEC_NET_HOST);
val = Obj_Value(spec, STD_PORT_SPEC_NET_PORT_ID);
if (OS_DO_DEVICE(sock, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
SET_OPEN(sock);
// Lookup host name (an extra TCP device step):
if (IS_STRING(arg)) {
sock->common.data = VAL_BIN(arg);
sock->special.net.remote_port = IS_INTEGER(val) ? VAL_INT32(val) : 80;
result = OS_DO_DEVICE(sock, RDC_LOOKUP); // sets remote_ip field
if (result < 0)
fail (Error_On_Port(RE_NO_CONNECT, port, sock->error));
return R_OUT;
}
// Host IP specified:
else if (IS_TUPLE(arg)) {
sock->special.net.remote_port = IS_INTEGER(val) ? VAL_INT32(val) : 80;
memcpy(&sock->special.net.remote_ip, VAL_TUPLE(arg), 4);
break;
}
// No host, must be a LISTEN socket:
else if (IS_NONE(arg)) {
SET_FLAG(sock->modes, RST_LISTEN);
sock->common.data = 0; // where ACCEPT requests are queued
sock->special.net.local_port = IS_INTEGER(val) ? VAL_INT32(val) : 8000;
break;
}
else
fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
case A_CLOSE:
return R_OUT;
case A_OPENQ:
return R_FALSE;
case A_UPDATE: // allowed after a close
break;
default:
fail (Error_On_Port(RE_NOT_OPEN, port, -12));
}
}
// Actions for an open socket:
switch (action) { // Ordered by frequency
case A_UPDATE:
// Update the port object after a READ or WRITE operation.
// This is normally called by the WAKE-UP function.
arg = OFV(port, STD_PORT_DATA);
if (sock->command == RDC_READ) {
if (ANY_BINSTR(arg)) VAL_TAIL(arg) += sock->actual;
}
else if (sock->command == RDC_WRITE) {
SET_NONE(arg); // Write is done.
}
return R_NONE;
case A_READ:
// Read data into a buffer, expanding the buffer if needed.
// If no length is given, program must stop it at some point.
refs = Find_Refines(call_, ALL_READ_REFS);
if (
!GET_FLAG(sock->modes, RST_UDP)
&& !GET_FLAG(sock->state, RSM_CONNECT)
) {
fail (Error_On_Port(RE_NOT_CONNECTED, port, -15));
}
// Setup the read buffer (allocate a buffer if needed):
arg = OFV(port, STD_PORT_DATA);
if (!IS_STRING(arg) && !IS_BINARY(arg)) {
Val_Init_Binary(arg, Make_Binary(NET_BUF_SIZE));
}
ser = VAL_SERIES(arg);
sock->length = SERIES_AVAIL(ser); // space available
if (sock->length < NET_BUF_SIZE/2) Extend_Series(ser, NET_BUF_SIZE);
sock->length = SERIES_AVAIL(ser);
sock->common.data = STR_TAIL(ser); // write at tail
//if (SERIES_TAIL(ser) == 0)
sock->actual = 0; // Actual for THIS read, not for total.
//Print("(max read length %d)", sock->length);
result = OS_DO_DEVICE(sock, RDC_READ); // recv can happen immediately
if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, sock->error));
break;
case A_WRITE:
// Write the entire argument string to the network.
// The lower level write code continues until done.
refs = Find_Refines(call_, ALL_WRITE_REFS);
if (!GET_FLAG(sock->modes, RST_UDP)
&& !GET_FLAG(sock->state, RSM_CONNECT))
fail (Error_On_Port(RE_NOT_CONNECTED, port, -15));
// Determine length. Clip /PART to size of string if needed.
spec = D_ARG(2);
len = VAL_LEN(spec);
if (refs & AM_WRITE_PART) {
REBCNT n = Int32s(D_ARG(ARG_WRITE_LIMIT), 0);
if (n <= len) len = n;
}
// Setup the write:
*OFV(port, STD_PORT_DATA) = *spec; // keep it GC safe
sock->length = len;
sock->common.data = VAL_BIN_DATA(spec);
sock->actual = 0;
//Print("(write length %d)", len);
result = OS_DO_DEVICE(sock, RDC_WRITE); // send can happen immediately
if (result < 0) fail (Error_On_Port(RE_WRITE_ERROR, port, sock->error));
if (result == DR_DONE) SET_NONE(OFV(port, STD_PORT_DATA));
break;
case A_PICK:
// FIRST server-port returns new port connection.
len = Get_Num_Arg(arg); // Position
if (len == 1 && GET_FLAG(sock->modes, RST_LISTEN) && sock->common.data)
Accept_New_Port(D_OUT, port, sock); // sets D_OUT
else
fail (Error_Out_Of_Range(arg));
break;
case A_QUERY:
// Get specific information - the scheme's info object.
// Special notation allows just getting part of the info.
Ret_Query_Net(port, sock, D_OUT);
break;
case A_OPENQ:
// Connect for clients, bind for servers:
if (sock->state & ((1<<RSM_CONNECT) | (1<<RSM_BIND))) return R_TRUE;
return R_FALSE;
case A_CLOSE:
if (IS_OPEN(sock)) {
OS_DO_DEVICE(sock, RDC_CLOSE);
SET_CLOSED(sock);
}
break;
case A_LENGTH:
arg = OFV(port, STD_PORT_DATA);
len = ANY_SERIES(arg) ? VAL_TAIL(arg) : 0;
SET_INTEGER(D_OUT, len);
break;
case A_OPEN:
result = OS_DO_DEVICE(sock, RDC_CONNECT);
if (result < 0)
fail (Error_On_Port(RE_NO_CONNECT, port, sock->error));
break;
case A_DELETE: // Temporary to TEST error handler!
{
REBVAL *event = Append_Event(); // sets signal
VAL_SET(event, REB_EVENT); // (has more space, if we need it)
VAL_EVENT_TYPE(event) = EVT_ERROR;
VAL_EVENT_DATA(event) = 101;
VAL_EVENT_REQ(event) = sock;
}
break;
default:
fail (Error_Illegal_Action(REB_PORT, action));
}
return R_OUT;
}
*/ void Resolve_Context(REBSER *target, REBSER *source, REBVAL *only_words, REBFLG all, REBFLG expand)
/*
** Only_words can be a block of words or an index in the target
** (for new words).
**
***********************************************************************/
{
REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
REBVAL *words;
REBVAL *vals;
REBINT n;
REBINT m;
REBCNT i = 0;
CHECK_BIND_TABLE;
if (IS_PROTECT_SERIES(target)) Trap0(RE_PROTECTED);
if (IS_INTEGER(only_words)) { // Must be: 0 < i <= tail
i = VAL_INT32(only_words); // never <= 0
if (i == 0) i = 1;
if (i >= target->tail) return;
}
Collect_Start(BIND_NO_SELF); // DO NOT TRAP IN THIS SECTION
n = 0;
// If limited resolve, tag the word ids that need to be copied:
if (i) {
// Only the new words of the target:
for (words = FRM_WORD(target, i); NOT_END(words); words++)
binds[VAL_BIND_CANON(words)] = -1;
n = SERIES_TAIL(target) - 1;
}
else if (IS_BLOCK(only_words)) {
// Limit exports to only these words:
for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) {
if (IS_WORD(words) || IS_SET_WORD(words)) {
binds[VAL_WORD_CANON(words)] = -1;
n++;
}
}
}
// Expand target as needed:
if (expand && n > 0) {
// Determine how many new words to add:
for (words = FRM_WORD(target, 1); NOT_END(words); words++)
if (binds[VAL_BIND_CANON(words)]) n--;
// Expand frame by the amount required:
if (n > 0) Expand_Frame(target, n, 0);
else expand = 0;
}
// Maps a word to its value index in the source context.
// Done by marking all source words (in bind table):
words = FRM_WORDS(source)+1;
for (n = 1; NOT_END(words); n++, words++) {
if (IS_NONE(only_words) || binds[VAL_BIND_CANON(words)])
binds[VAL_WORD_CANON(words)] = n;
}
// Foreach word in target, copy the correct value from source:
n = i ? i : 1;
vals = FRM_VALUE(target, n);
for (words = FRM_WORD(target, n); NOT_END(words); words++, vals++) {
if ((m = binds[VAL_BIND_CANON(words)])) {
binds[VAL_BIND_CANON(words)] = 0; // mark it as set
if (!VAL_PROTECTED(words) && (all || IS_UNSET(vals))) {
if (m < 0) SET_UNSET(vals); // no value in source context
else *vals = *FRM_VALUE(source, m);
//Debug_Num("type:", VAL_TYPE(vals));
//Debug_Str(Get_Word_Name(words));
}
}
}
// Add any new words and values:
if (expand) {
REBVAL *val;
words = FRM_WORDS(source)+1;
for (n = 1; NOT_END(words); n++, words++) {
if (binds[VAL_BIND_CANON(words)]) {
// Note: no protect check is needed here
binds[VAL_BIND_CANON(words)] = 0;
val = Append_Frame(target, 0, VAL_BIND_SYM(words));
*val = *FRM_VALUE(source, n);
}
}
}
else {
// Reset bind table (do not use Collect_End):
if (i) {
for (words = FRM_WORD(target, i); NOT_END(words); words++)
binds[VAL_BIND_CANON(words)] = 0;
}
else if (IS_BLOCK(only_words)) {
for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) {
if (IS_WORD(words) || IS_SET_WORD(words)) binds[VAL_WORD_CANON(words)] = 0;
}
}
else {
for (words = FRM_WORDS(source)+1; NOT_END(words); words++)
binds[VAL_BIND_CANON(words)] = 0;
}
}
CHECK_BIND_TABLE;
RESET_TAIL(BUF_WORDS); // allow reuse, trapping ok now
}
*/ 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;
}
*/ REBINT Text_Gob(void *richtext, REBSER *block)
/*
** Handles all commands for the TEXT dialect as specified
** in the system/dialects/text object.
**
** This function calls the REBOL_Dialect interpreter to
** parse the dialect and build and return the command number
** (the index offset in the text object above) and a block
** of arguments. (For now, just a REBOL block, but this could
** be changed to isolate it from changes in REBOL's internals).
**
** Each arg will be of the specified datatype (given in the
** dialect) or NONE when no argument of that type was given
** and this code must determine the proper default value.
**
** If the cmd result is zero, then it is either the end of
** the block, or an error has occurred. If the error value
** is non-zero, then it was an error.
**
***********************************************************************/
{
REBCNT index = 0;
REBINT cmd;
REBSER *args = 0;
REBVAL *arg;
REBCNT nargs;
//font object conversion related values
REBFNT* font;
REBVAL* val;
REBPAR offset;
REBPAR space;
//para object conversion related values
REBPRA* para;
REBPAR origin;
REBPAR margin;
REBPAR indent;
REBPAR scroll;
do {
cmd = Reb_Dialect(DIALECTS_TEXT, block, &index, &args);
if (cmd == 0) return 0;
if (cmd < 0) {
// Reb_Print("ERROR: %d, Index %d", -cmd, index);
return -((REBINT)index+1);
}
// else
// Reb_Print("TEXT: Cmd %d, Index %d, Args %m", cmd, index, args);
arg = BLK_HEAD(args);
nargs = SERIES_TAIL(args);
// Reb_Print("Number of args: %d", nargs);
switch (cmd) {
case TW_TYPE_SPEC:
if (IS_STRING(arg)) {
rt_text(richtext, ARG_STRING(0), index);
} else if (IS_TUPLE(arg)) {
rt_color(richtext, ARG_TUPLE(0));
}
break;
case TW_ANTI_ALIAS:
rt_anti_alias(richtext, ARG_OPT_LOGIC(0));
break;
case TW_SCROLL:
rt_scroll(richtext, ARG_PAIR(0));
break;
case TW_BOLD:
case TW_B:
rt_bold(richtext, ARG_OPT_LOGIC(0));
break;
case TW_ITALIC:
case TW_I:
rt_italic(richtext, ARG_OPT_LOGIC(0));
break;
case TW_UNDERLINE:
case TW_U:
rt_underline(richtext, ARG_OPT_LOGIC(0));
break;
case TW_CENTER:
rt_center(richtext);
break;
case TW_LEFT:
rt_left(richtext);
break;
case TW_RIGHT:
rt_right(richtext);
break;
case TW_FONT:
if (!IS_OBJECT(arg)) break;
font = (REBFNT*)rt_get_font(richtext);
val = BLK_HEAD(ARG_OBJECT(0))+1;
if (IS_STRING(val)) {
font->name = VAL_STRING(val);
}
// Reb_Print("font/name: %s", font->name);
val++;
if (IS_BLOCK(val)) {
REBSER* styles = VAL_SERIES(val);
REBVAL* slot = BLK_HEAD(styles);
REBCNT len = SERIES_TAIL(styles) ,i;
for (i = 0;i<len;i++){
if (IS_WORD(slot+i)){
set_font_styles(font, slot+i);
}
}
} else if (IS_WORD(val)) {
set_font_styles(font, val);
}
val++;
if (IS_INTEGER(val)) {
font->size = VAL_INT32(val);
}
// Reb_Print("font/size: %d", font->size);
val++;
if ((IS_TUPLE(val)) || (IS_NONE(val))) {
COPY_MEM(font->color,VAL_TUPLE(val), 4);
}
// Reb_Print("font/color: %d.%d.%d.%d", font->color[0],font->color[1],font->color[2],font->color[3]);
val++;
if ((IS_PAIR(val)) || (IS_NONE(val))) {
offset = VAL_PAIR(val);
font->offset_x = offset.x;
font->offset_y = offset.y;
}
// Reb_Print("font/offset: %dx%d", offset.x,offset.y);
val++;
if ((IS_PAIR(val)) || (IS_NONE(val))) {
space = VAL_PAIR(val);
font->space_x = space.x;
font->space_y = space.y;
}
// Reb_Print("font/space: %dx%d", space.x, space.y);
val++;
font->shadow_x = 0;
font->shadow_y = 0;
if (IS_BLOCK(val)) {
REBSER* ser = VAL_SERIES(val);
REBVAL* slot = BLK_HEAD(ser);
REBCNT len = SERIES_TAIL(ser) ,i;
for (i = 0;i<len;i++){
if (IS_PAIR(slot)) {
REBPAR shadow = VAL_PAIR(slot);
font->shadow_x = shadow.x;
font->shadow_y = shadow.y;
} else if (IS_TUPLE(slot)) {
COPY_MEM(font->shadow_color,VAL_TUPLE(slot), 4);
} else if (IS_INTEGER(slot)) {
font->shadow_blur = VAL_INT32(slot);
}
slot++;
}
} else if (IS_PAIR(val)) {
REBPAR shadow = VAL_PAIR(val);
font->shadow_x = shadow.x;
font->shadow_y = shadow.y;
}
rt_font(richtext, font);
break;
case TW_PARA:
if (!IS_OBJECT(arg)) break;
para = (REBPRA*)rt_get_para(richtext);
val = BLK_HEAD(ARG_OBJECT(0))+1;
if (IS_PAIR(val)) {
origin = VAL_PAIR(val);
para->origin_x = origin.x;
para->origin_y = origin.y;
}
// Reb_Print("para/origin: %dx%d", origin.x, origin.y);
val++;
if (IS_PAIR(val)) {
margin = VAL_PAIR(val);
para->margin_x = margin.x;
para->margin_y = margin.y;
}
// Reb_Print("para/margin: %dx%d", margin.x, margin.y);
val++;
if (IS_PAIR(val)) {
indent = VAL_PAIR(val);
para->indent_x = indent.x;
para->indent_y = indent.y;
}
// Reb_Print("para/indent: %dx%d", indent.x, indent.y);
val++;
if (IS_INTEGER(val)) {
para->tabs = VAL_INT32(val);
}
// Reb_Print("para/tabs: %d", para->tabs);
val++;
if (IS_LOGIC(val)) {
para->wrap = VAL_LOGIC(val);
}
// Reb_Print("para/wrap?: %d", para->wrap);
val++;
if (IS_PAIR(val)) {
scroll = VAL_PAIR(val);
para->scroll_x = scroll.x;
para->scroll_y = scroll.y;
}
// Reb_Print("para/scroll: %dx%d", scroll.x, scroll.y);
val++;
if (IS_WORD(val)) {
REBINT result = Reb_Find_Word(VAL_WORD_SYM(val), Symbol_Ids, 0);
switch (result){
case SW_RIGHT:
case SW_LEFT:
case SW_CENTER:
para->align = result;
break;
default:
para->align = SW_LEFT;
break;
}
}
val++;
if (IS_WORD(val)) {
REBINT result = Reb_Find_Word(VAL_WORD_SYM(val), Symbol_Ids, 0);
switch (result){
case SW_TOP:
case SW_BOTTOM:
case SW_MIDDLE:
para->valign = result;
break;
default:
para->valign = SW_TOP;
break;
}
}
rt_para(richtext, para);
break;
case TW_SIZE:
rt_font_size(richtext, ARG_INTEGER(0));
break;
case TW_SHADOW:
rt_shadow(richtext, &ARG_PAIR(0), ARG_TUPLE(1), ARG_INTEGER(2));
break;
case TW_DROP:
rt_drop(richtext, ARG_OPT_INTEGER(0));
break;
case TW_NEWLINE:
case TW_NL:
rt_newline(richtext, index);
break;
case TW_CARET:
{
REBPAR caret = {0,0};
REBPAR highlightStart = {0,0};
REBPAR highlightEnd = {0,0};
REBVAL *slot;
if (!IS_OBJECT(arg)) break;
val = BLK_HEAD(ARG_OBJECT(0))+1;
if (IS_BLOCK(val)) {
slot = BLK_HEAD(VAL_SERIES(val));
if (SERIES_TAIL(VAL_SERIES(val)) == 2 && IS_BLOCK(slot) && IS_STRING(slot+1)){
caret.x = 1 + slot->data.series.index;
caret.y = 1 + (slot+1)->data.series.index;;
//Reb_Print("caret %d, %d", caret.x, caret.y);
}
}
val++;
if (IS_BLOCK(val)) {
slot = BLK_HEAD(VAL_SERIES(val));
if (SERIES_TAIL(VAL_SERIES(val)) == 2 && IS_BLOCK(slot) && IS_STRING(slot+1)){
highlightStart.x = 1 + slot->data.series.index;
highlightStart.y = 1 + (slot+1)->data.series.index;;
//Reb_Print("highlight-start %d, %d", highlightStart.x, highlightStart.y);
}
}
val++;
if (IS_BLOCK(val)) {
slot = BLK_HEAD(VAL_SERIES(val));
if (SERIES_TAIL(VAL_SERIES(val)) == 2 && IS_BLOCK(slot) && IS_STRING(slot+1)){
highlightEnd.x = 1 + slot->data.series.index;
highlightEnd.y = 1 + (slot+1)->data.series.index;;
//Reb_Print("highlight-End %d, %d", highlightEnd.x, highlightEnd.y);
}
}
rt_caret(richtext, &caret, &highlightStart,&highlightEnd);
}
break;
}
} while (TRUE);
}
*/ REBINT Partial(REBVAL *aval, REBVAL *bval, REBVAL *lval, REBFLG flag)
/*
** Args:
** aval: target value
** bval: argument to modify target (optional)
** lval: length value (or none)
**
** Determine the length of a /PART value. It can be:
** 1. integer or decimal
** 2. relative to A value (bval is null)
** 3. relative to B value
**
** Flag: indicates special treatment for CHANGE. As in:
** CHANGE/part "abcde" "xy" 3 => "xyde"
**
** NOTE: Can modify the value's index!
** The result can be negative. ???
**
***********************************************************************/
{
REBVAL *val;
REBINT len;
REBINT maxlen;
// If lval = NONE, use the current len of the target value:
if (IS_NONE(lval)) {
val = (bval && ANY_SERIES(bval)) ? bval : aval;
if (VAL_INDEX(val) >= VAL_TAIL(val)) return 0;
return (VAL_TAIL(val) - VAL_INDEX(val));
}
if (IS_INTEGER(lval)) {
len = Int32(lval);
val = flag ? aval : bval;
}
else if (IS_DECIMAL(lval)) {
len = Int32(lval);
val = bval;
}
else {
// So, lval must be relative to aval or bval series:
if (VAL_TYPE(aval) == VAL_TYPE(lval) && VAL_SERIES(aval) == VAL_SERIES(lval))
val = aval;
else if (bval && VAL_TYPE(bval) == VAL_TYPE(lval) && VAL_SERIES(bval) == VAL_SERIES(lval))
val = bval;
else
Trap1(RE_INVALID_PART, lval);
len = (REBINT)VAL_INDEX(lval) - (REBINT)VAL_INDEX(val);
}
if (!val) val = aval;
// Restrict length to the size available:
if (len >= 0) {
maxlen = (REBINT)VAL_LEN(val);
if (len > maxlen) len = maxlen;
} else {
len = -len;
if (len > (REBINT)VAL_INDEX(val)) len = (REBINT)VAL_INDEX(val);
VAL_INDEX(val) -= (REBCNT)len;
// if ((-len) > (REBINT)VAL_INDEX(val)) len = -(REBINT)VAL_INDEX(val);
}
return len;
}
//
// Do_Breakpoint_Throws: C
//
// A call to Do_Breakpoint_Throws does delegation to a hook in the host, which
// (if registered) will generally start an interactive session for probing the
// environment at the break. The `resume` native cooperates by being able to
// give back a value (or give back code to run to produce a value) that the
// call to breakpoint returns.
//
// RESUME has another feature, which is to be able to actually unwind and
// simulate a return /AT a function *further up the stack*. (This may be
// switched to a feature of a "STEP OUT" command at some point.)
//
REBOOL Do_Breakpoint_Throws(
REBVAL *out,
REBOOL interrupted, // Ctrl-C (as opposed to a BREAKPOINT)
const REBVAL *default_value,
REBOOL do_default
) {
REBVAL *target = NONE_VALUE;
REBVAL temp;
VAL_INIT_WRITABLE_DEBUG(&temp);
if (!PG_Breakpoint_Quitting_Hook) {
//
// Host did not register any breakpoint handler, so raise an error
// about this as early as possible.
//
fail (Error(RE_HOST_NO_BREAKPOINT));
}
// We call the breakpoint hook in a loop, in order to keep running if any
// inadvertent FAILs or THROWs occur during the interactive session.
// Only a conscious call of RESUME speaks the protocol to break the loop.
//
while (TRUE) {
struct Reb_State state;
REBCTX *error;
push_trap:
PUSH_TRAP(&error, &state);
// The host may return a block of code to execute, but cannot
// while evaluating do a THROW or a FAIL that causes an effective
// "resumption". Halt is the exception, hence we PUSH_TRAP and
// not PUSH_UNHALTABLE_TRAP. QUIT is also an exception, but a
// desire to quit is indicated by the return value of the breakpoint
// hook (which may or may not decide to request a quit based on the
// QUIT command being run).
//
// The core doesn't want to get involved in presenting UI, so if
// an error makes it here and wasn't trapped by the host first that
// is a bug in the host. It should have done its own PUSH_TRAP.
//
if (error) {
#if !defined(NDEBUG)
REBVAL error_value;
VAL_INIT_WRITABLE_DEBUG(&error_value);
Val_Init_Error(&error_value, error);
PROBE_MSG(&error_value, "Error not trapped during breakpoint:");
Panic_Array(CTX_VARLIST(error));
#endif
// In release builds, if an error managed to leak out of the
// host's breakpoint hook somehow...just re-push the trap state
// and try it again.
//
goto push_trap;
}
// Call the host's breakpoint hook.
//
if (PG_Breakpoint_Quitting_Hook(&temp, interrupted)) {
//
// If a breakpoint hook returns TRUE that means it wants to quit.
// The value should be the /WITH value (as in QUIT/WITH)
//
assert(!THROWN(&temp));
*out = *ROOT_QUIT_NATIVE;
CONVERT_NAME_TO_THROWN(out, &temp, FALSE);
return TRUE; // TRUE = threw
}
// If a breakpoint handler returns FALSE, then it should have passed
// back a "resume instruction" triggered by a call like:
//
// resume/do [fail "This is how to fail from a breakpoint"]
//
// So now that the handler is done, we will allow any code handed back
// to do whatever FAIL it likes vs. trapping that here in a loop.
//
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
// Decode and process the "resume instruction"
{
struct Reb_Frame *frame;
REBVAL *mode;
REBVAL *payload;
assert(IS_GROUP(&temp));
assert(VAL_LEN_HEAD(&temp) == RESUME_INST_MAX);
mode = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_MODE);
payload = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_PAYLOAD);
target = VAL_ARRAY_AT_HEAD(&temp, RESUME_INST_TARGET);
// The first thing we need to do is determine if the target we
// want to return to has another breakpoint sandbox blocking
// us. If so, what we need to do is actually retransmit the
// resume instruction so it can break that wall, vs. transform
// it into an EXIT/FROM that would just get intercepted.
//
if (!IS_NONE(target)) {
#if !defined(NDEBUG)
REBOOL found = FALSE;
#endif
for (frame = FS_TOP; frame != NULL; frame = frame->prior) {
if (frame->mode != CALL_MODE_FUNCTION)
continue;
if (
frame != FS_TOP
&& FUNC_CLASS(frame->func) == FUNC_CLASS_NATIVE
&& (
FUNC_CODE(frame->func) == &N_pause
|| FUNC_CODE(frame->func) == &N_breakpoint
)
) {
// We hit a breakpoint (that wasn't this call to
// breakpoint, at the current FS_TOP) before finding
// the sought after target. Retransmit the resume
// instruction so that level will get it instead.
//
*out = *ROOT_RESUME_NATIVE;
CONVERT_NAME_TO_THROWN(out, &temp, FALSE);
return TRUE; // TRUE = thrown
}
if (IS_FRAME(target)) {
if (NOT(frame->flags & DO_FLAG_FRAME_CONTEXT))
continue;
if (
VAL_CONTEXT(target)
== AS_CONTEXT(frame->data.context)
) {
// Found a closure matching the target before we
// reached a breakpoint, no need to retransmit.
//
#if !defined(NDEBUG)
found = TRUE;
#endif
break;
}
}
else {
assert(IS_FUNCTION(target));
if (frame->flags & DO_FLAG_FRAME_CONTEXT)
continue;
if (VAL_FUNC(target) == frame->func) {
//
// Found a function matching the target before we
// reached a breakpoint, no need to retransmit.
//
#if !defined(NDEBUG)
found = TRUE;
#endif
break;
}
}
}
// RESUME should not have been willing to use a target that
// is not on the stack.
//
#if !defined(NDEBUG)
assert(found);
#endif
}
if (IS_NONE(mode)) {
//
// If the resume instruction had no /DO or /WITH of its own,
// then it doesn't override whatever the breakpoint provided
// as a default. (If neither the breakpoint nor the resume
// provided a /DO or a /WITH, result will be UNSET.)
//
goto return_default; // heeds `target`
}
assert(IS_LOGIC(mode));
if (VAL_LOGIC(mode)) {
if (DO_VAL_ARRAY_AT_THROWS(&temp, payload)) {
//
// Throwing is not compatible with /AT currently.
//
if (!IS_NONE(target))
fail (Error_No_Catch_For_Throw(&temp));
// Just act as if the BREAKPOINT call itself threw
//
*out = temp;
return TRUE; // TRUE = thrown
}
// Ordinary evaluation result...
}
else
temp = *payload;
}
// The resume instruction will be GC'd.
//
goto return_temp;
}
DEAD_END;
return_default:
if (do_default) {
if (DO_VAL_ARRAY_AT_THROWS(&temp, default_value)) {
//
// If the code throws, we're no longer in the sandbox...so we
// bubble it up. Note that breakpoint runs this code at its
// level... so even if you request a higher target, any throws
// will be processed as if they originated at the BREAKPOINT
// frame. To do otherwise would require the EXIT/FROM protocol
// to add support for DO-ing at the receiving point.
//
*out = temp;
return TRUE; // TRUE = thrown
}
}
else
temp = *default_value; // generally UNSET! if no /WITH
return_temp:
// The easy case is that we just want to return from breakpoint
// directly, signaled by the target being NONE!.
//
if (IS_NONE(target)) {
*out = temp;
return FALSE; // FALSE = not thrown
}
// If the target is a function, then we're looking to simulate a return
// from something up the stack. This uses the same mechanic as
// definitional returns--a throw named by the function or closure frame.
//
// !!! There is a weak spot in definitional returns for FUNCTION! that
// they can only return to the most recent invocation; which is a weak
// spot of FUNCTION! in general with stack relative variables. Also,
// natives do not currently respond to definitional returns...though
// they can do so just as well as FUNCTION! can.
//
*out = *target;
CONVERT_NAME_TO_THROWN(out, &temp, TRUE);
return TRUE; // TRUE = thrown
}
*/ 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;
}
//
// Find_Entry: C
//
// Try to find the entry in the map. If not found
// and val is SET, create the entry and store the key and
// val.
//
// RETURNS: the index to the VALUE or zero if there is none.
//
static REBCNT Find_Entry(REBSER *series, REBVAL *key, REBVAL *val)
{
REBSER *hser = series->extra.series; // can be null
REBCNT *hashes;
REBCNT hash;
REBVAL *v;
REBCNT n;
if (IS_NONE(key)) return 0;
// We may not be large enough yet for the hash table to
// be worthwhile, so just do a linear search:
if (!hser) {
if (series->tail < MIN_DICT*2) {
v = BLK_HEAD(series);
if (ANY_WORD(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (
ANY_WORD(v)
&& SAME_SYM(VAL_WORD_SYM(key), VAL_WORD_SYM(v))
) {
if (val) *++v = *val;
return n/2+1;
}
}
}
else if (ANY_BINSTR(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (VAL_TYPE(key) == VAL_TYPE(v) && 0 == Compare_String_Vals(key, v, (REBOOL)!IS_BINARY(v))) {
if (val)
*++v = *val;
return n/2+1;
}
}
}
else if (IS_INTEGER(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (IS_INTEGER(v) && VAL_INT64(key) == VAL_INT64(v)) {
if (val) *++v = *val;
return n/2+1;
}
}
}
else if (IS_CHAR(key)) {
for (n = 0; n < series->tail; n += 2, v += 2) {
if (IS_CHAR(v) && VAL_CHAR(key) == VAL_CHAR(v)) {
if (val) *++v = *val;
return n/2+1;
}
}
}
else
fail (Error_Has_Bad_Type(key));
if (!val) return 0;
Append_Value(series, key);
Append_Value(series, val); // does not copy value, e.g. if string
return series->tail/2;
}
// Add hash table:
//Print("hash added %d", series->tail);
series->extra.series = hser = Make_Hash_Sequence(series->tail);
MANAGE_SERIES(hser);
Rehash_Hash(series);
}
// Get hash table, expand it if needed:
if (series->tail > hser->tail/2) {
Expand_Hash(hser); // modifies size value
Rehash_Hash(series);
}
hash = Find_Key(series, hser, key, 2, 0, 0);
hashes = (REBCNT*)hser->data;
n = hashes[hash];
// Just a GET of value:
if (!val) return n;
// Must set the value:
if (n) { // re-set it:
*BLK_SKIP(series, ((n-1)*2)+1) = *val; // set it
return n;
}
// Create new entry:
Append_Value(series, key);
Append_Value(series, val); // does not copy value, e.g. if string
return (hashes[hash] = series->tail/2);
}
*/ REBINT PD_Time(REBPVS *pvs)
/*
***********************************************************************/
{
REBVAL *val;
REBINT i;
REBINT n;
REBDEC f;
REB_TIMEF tf;
if (IS_WORD(pvs->select)) {
switch (VAL_WORD_CANON(pvs->select)) {
case SYM_HOUR: i = 0; break;
case SYM_MINUTE: i = 1; break;
case SYM_SECOND: i = 2; break;
default: return PE_BAD_SELECT;
}
}
else if (IS_INTEGER(pvs->select))
i = VAL_INT32(pvs->select) - 1;
else
return PE_BAD_SELECT;
Split_Time(VAL_TIME(pvs->value), &tf); // loses sign
if (!(val = pvs->setval)) {
val = pvs->store;
switch(i) {
case 0: // hours
SET_INTEGER(val, tf.h);
break;
case 1:
SET_INTEGER(val, tf.m);
break;
case 2:
if (tf.n == 0)
SET_INTEGER(val, tf.s);
else
SET_DECIMAL(val, (REBDEC)tf.s + (tf.n * NANO));
break;
default:
return PE_NONE;
}
return PE_USE;
} else {
if (IS_INTEGER(val) || IS_DECIMAL(val)) n = Int32s(val, 0);
else if (IS_NONE(val)) n = 0;
else return PE_BAD_SET;
switch(i) {
case 0:
tf.h = n;
break;
case 1:
tf.m = n;
break;
case 2:
if (IS_DECIMAL(val)) {
f = VAL_DECIMAL(val);
if (f < 0.0) Trap_Range_DEAD_END(val);
tf.s = (REBINT)f;
tf.n = (REBINT)((f - tf.s) * SEC_SEC);
}
else {
tf.s = n;
tf.n = 0;
}
break;
default:
return PE_BAD_SELECT;
}
VAL_TIME(pvs->value) = Join_Time(&tf, FALSE);
return PE_OK;
}
}
*/ 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
}
