//
// Partial1: C
//
// Process the /part (or /skip) and other length modifying
// arguments.
//
REBINT Partial1(REBVAL *sval, REBVAL *lval)
{
REBI64 len;
REBINT maxlen;
REBINT is_ser = ANY_SERIES(sval);
// If lval is not set or is BAR!, use the current len of the target value:
if (IS_UNSET(lval) || IS_BAR(lval)) {
if (!is_ser) return 1;
if (VAL_INDEX(sval) >= VAL_LEN_HEAD(sval)) return 0;
return (VAL_LEN_HEAD(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
fail (Error(RE_INVALID_PART, lval));
}
if (is_ser) {
// Restrict length to the size available:
if (len >= 0) {
maxlen = (REBINT)VAL_LEN_AT(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;
}
//
// Find_Max_Bit: C
//
// Return integer number for the maximum bit number defined by
// the value. Used to determine how much space to allocate.
//
REBINT Find_Max_Bit(REBVAL *val)
{
REBINT maxi = 0;
REBINT n;
switch (VAL_TYPE(val)) {
case REB_CHAR:
maxi = VAL_CHAR(val)+1;
break;
case REB_INTEGER:
maxi = Int32s(val, 0);
break;
case REB_STRING:
case REB_FILE:
case REB_EMAIL:
case REB_URL:
case REB_TAG:
// case REB_ISSUE:
n = VAL_INDEX(val);
if (VAL_BYTE_SIZE(val)) {
REBYTE *bp = VAL_BIN(val);
for (; n < cast(REBINT, VAL_LEN_HEAD(val)); n++)
if (bp[n] > maxi) maxi = bp[n];
}
else {
REBUNI *up = VAL_UNI(val);
for (; n < cast(REBINT, VAL_LEN_HEAD(val)); n++)
if (up[n] > maxi) maxi = up[n];
}
maxi++;
break;
case REB_BINARY:
maxi = VAL_LEN_AT(val) * 8 - 1;
if (maxi < 0) maxi = 0;
break;
case REB_BLOCK:
for (val = VAL_ARRAY_AT(val); NOT_END(val); val++) {
n = Find_Max_Bit(val);
if (n > maxi) maxi = n;
}
//maxi++;
break;
case REB_NONE:
maxi = 0;
break;
default:
return -1;
}
return maxi;
}
//
// Partial: C
//
// 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
//
// NOTE: Can modify the value's index!
// The result can be negative. ???
//
REBINT Partial(REBVAL *aval, REBVAL *bval, REBVAL *lval)
{
REBVAL *val;
REBINT len;
REBINT maxlen;
// If lval is unset, use the current len of the target value:
if (IS_UNSET(lval)) {
val = (bval && ANY_SERIES(bval)) ? bval : aval;
if (VAL_INDEX(val) >= VAL_LEN_HEAD(val)) return 0;
return (VAL_LEN_HEAD(val) - VAL_INDEX(val));
}
if (IS_INTEGER(lval) || 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
fail (Error(RE_INVALID_PART, lval));
len = cast(REBINT, VAL_INDEX(lval)) - cast(REBINT, VAL_INDEX(val));
}
if (!val) val = aval;
// Restrict length to the size available
//
if (len >= 0) {
maxlen = (REBINT)VAL_LEN_AT(val);
if (len > maxlen) len = maxlen;
}
else {
len = -len;
if (len > cast(REBINT, VAL_INDEX(val)))
len = cast(REBINT, VAL_INDEX(val));
VAL_INDEX(val) -= (REBCNT)len;
}
return len;
}
//
// Check_Bit_Str: C
//
// If uncased is TRUE, try to match either upper or lower case.
//
REBOOL Check_Bit_Str(REBSER *bset, const REBVAL *val, REBOOL uncased)
{
REBCNT n = VAL_INDEX(val);
if (VAL_BYTE_SIZE(val)) {
REBYTE *bp = VAL_BIN(val);
for (; n < VAL_LEN_HEAD(val); n++)
if (Check_Bit(bset, bp[n], uncased)) return TRUE;
}
else {
REBUNI *up = VAL_UNI(val);
for (; n < VAL_LEN_HEAD(val); n++)
if (Check_Bit(bset, up[n], uncased)) return TRUE;
}
return FALSE;
}
//
// Resolve_Path: C
//
// Given a path, return a context and index for its terminal.
//
REBCTX *Resolve_Path(REBVAL *path, REBCNT *index)
{
REBVAL *sel; // selector
const REBVAL *val;
REBARR *blk;
REBCNT i;
if (VAL_LEN_HEAD(path) < 2) return 0;
blk = VAL_ARRAY(path);
sel = ARR_HEAD(blk);
if (!ANY_WORD(sel)) return 0;
val = GET_OPT_VAR_MAY_FAIL(sel);
sel = ARR_AT(blk, 1);
while (TRUE) {
if (!ANY_CONTEXT(val) || !IS_WORD(sel)) return 0;
i = Find_Word_In_Context(VAL_CONTEXT(val), VAL_WORD_SYM(sel), FALSE);
sel++;
if (IS_END(sel)) {
*index = i;
return VAL_CONTEXT(val);
}
}
return 0; // never happens
}
//
// Temp_Byte_Chars_May_Fail: C
//
// NOTE: This function returns a temporary result, and uses an internal
// buffer. Do not use it recursively. Also, it will Trap on errors.
//
// Prequalifies a string before using it with a function that
// expects it to be 8-bits. It would be used for instance to convert
// a string that is potentially REBUNI-wide into a form that can be used
// with a Scan_XXX routine, that is expecting ASCII or UTF-8 source.
// (Many TO-XXX conversions from STRING re-use that scanner logic.)
//
// Returns a temporary string and sets the length field.
//
// If `allow_utf8`, the constructed result is converted to UTF8.
//
// Checks or converts it:
//
// 1. it is byte string (not unicode)
// 2. if unicode, copy and return as temp byte string
// 3. it's actual content (less space, newlines) <= max len
// 4. it does not contain other values ("123 456")
// 5. it's not empty or only whitespace
//
REBYTE *Temp_Byte_Chars_May_Fail(
const REBVAL *val,
REBINT max_len,
REBCNT *length,
REBOOL allow_utf8
) {
REBCNT tail = VAL_LEN_HEAD(val);
REBCNT index = VAL_INDEX(val);
REBCNT len;
REBUNI c;
REBYTE *bp;
REBSER *src = VAL_SERIES(val);
if (index > tail) fail (Error(RE_PAST_END));
Resize_Series(BYTE_BUF, max_len+1);
bp = BIN_HEAD(BYTE_BUF);
// Skip leading whitespace:
for (; index < tail; index++) {
c = GET_ANY_CHAR(src, index);
if (!IS_SPACE(c)) break;
}
// Copy chars that are valid:
for (; index < tail; index++) {
c = GET_ANY_CHAR(src, index);
if (c >= 0x80) {
if (!allow_utf8) fail (Error(RE_INVALID_CHARS));
len = Encode_UTF8_Char(bp, c);
max_len -= len;
bp += len;
}
else if (!IS_SPACE(c)) {
*bp++ = (REBYTE)c;
max_len--;
}
else break;
if (max_len < 0)
fail (Error(RE_TOO_LONG));
}
// Rest better be just spaces:
for (; index < tail; index++) {
c = GET_ANY_CHAR(src, index);
if (!IS_SPACE(c)) fail (Error(RE_INVALID_CHARS));
}
*bp = '\0';
len = bp - BIN_HEAD(BYTE_BUF);
if (len == 0) fail (Error(RE_TOO_SHORT));
if (length) *length = len;
return BIN_HEAD(BYTE_BUF);
}
//
// Vector_To_Array: C
//
// Convert a vector to a block.
//
REBARR *Vector_To_Array(const REBVAL *vect)
{
REBCNT len = VAL_LEN_AT(vect);
REBYTE *data = SER_DATA_RAW(VAL_SERIES(vect));
REBCNT type = VECT_TYPE(VAL_SERIES(vect));
REBARR *array = NULL;
REBCNT n;
RELVAL *val;
if (len <= 0)
fail (Error_Invalid_Arg(vect));
array = Make_Array(len);
val = ARR_HEAD(array);
for (n = VAL_INDEX(vect); n < VAL_LEN_HEAD(vect); n++, val++) {
VAL_RESET_HEADER(val, (type >= VTSF08) ? REB_DECIMAL : REB_INTEGER);
VAL_INT64(val) = get_vect(type, data, n); // can be int or decimal
}
TERM_ARRAY_LEN(array, len);
assert(IS_END(val));
return array;
}
//
// 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
}
//
// Val_Byte_Len: C
//
// Get length of series in bytes.
//
REBCNT Val_Byte_Len(const REBVAL *value)
{
if (VAL_INDEX(value) >= VAL_LEN_HEAD(value)) return 0;
return (VAL_LEN_HEAD(value) - VAL_INDEX(value)) * SER_WIDE(VAL_SERIES(value));
}
//
// Val_Series_Len_At: C
//
// Get length of an ANY-SERIES! value, taking the current index into account.
// Avoid negative values.
//
REBCNT Val_Series_Len_At(const REBVAL *value)
{
if (VAL_INDEX(value) >= VAL_LEN_HEAD(value)) return 0;
return VAL_LEN_HEAD(value) - VAL_INDEX(value);
}
//
// Make_Set_Operation_Series: C
//
// Do set operations on a series. Case-sensitive if `cased` is TRUE.
// `skip` is the record size.
//
static REBSER *Make_Set_Operation_Series(
const REBVAL *val1,
const REBVAL *val2,
REBFLGS flags,
REBOOL cased,
REBCNT skip
) {
REBCNT i;
REBINT h = 1; // used for both logic true/false and hash check
REBOOL first_pass = TRUE; // are we in the first pass over the series?
REBSER *out_ser;
assert(ANY_SERIES(val1));
if (val2) {
assert(ANY_SERIES(val2));
if (ANY_ARRAY(val1)) {
if (!ANY_ARRAY(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
// As long as they're both arrays, we're willing to do:
//
// >> union quote (a b c) 'b/d/e
// (a b c d e)
//
// The type of the result will match the first value.
}
else if (!IS_BINARY(val1)) {
// We will similarly do any two ANY-STRING! types:
//
// >> union <abc> "bde"
// <abcde>
if (IS_BINARY(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
}
else {
// Binaries only operate with other binaries
if (!IS_BINARY(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
}
}
// Calculate `i` as maximum length of result block. The temporary buffer
// will be allocated at this size, but copied out at the exact size of
// the actual result.
//
i = VAL_LEN_AT(val1);
if (flags & SOP_FLAG_BOTH) i += VAL_LEN_AT(val2);
if (ANY_ARRAY(val1)) {
REBSER *hser = 0; // hash table for series
REBSER *hret; // hash table for return series
// The buffer used for building the return series. Currently it
// reuses BUF_EMIT, because that buffer is not likely to be in
// use (emit doesn't call set operations, nor vice versa). However,
// other routines may get the same idea and start recursing so it
// may be better to use something more similar to the mold stack
// approach of marking off successive ranges in the array.
//
REBSER *buffer = ARR_SERIES(BUF_EMIT);
Resize_Series(buffer, i);
hret = Make_Hash_Sequence(i); // allocated
// Optimization note: !!
// This code could be optimized for small blocks by not hashing them
// and extending Find_Key to FIND on the value itself w/o the hash.
do {
REBARR *array1 = VAL_ARRAY(val1); // val1 and val2 swapped 2nd pass!
// Check what is in series1 but not in series2
//
if (flags & SOP_FLAG_CHECK)
hser = Hash_Block(val2, skip, cased);
// Iterate over first series
//
i = VAL_INDEX(val1);
for (; i < ARR_LEN(array1); i += skip) {
RELVAL *item = ARR_AT(array1, i);
if (flags & SOP_FLAG_CHECK) {
h = Find_Key_Hashed(
VAL_ARRAY(val2),
hser,
item,
VAL_SPECIFIER(val1),
skip,
cased,
1
);
h = (h >= 0);
if (flags & SOP_FLAG_INVERT) h = !h;
}
if (h) {
Find_Key_Hashed(
AS_ARRAY(buffer),
hret,
item,
VAL_SPECIFIER(val1),
skip,
cased,
2
);
}
}
if (i != ARR_LEN(array1)) {
//
// In the current philosophy, the semantics of what to do
// with things like `intersect/skip [1 2 3] [7] 2` is too
// shaky to deal with, so an error is reported if it does
// not work out evenly to the skip size.
//
fail (Error(RE_BLOCK_SKIP_WRONG));
}
if (flags & SOP_FLAG_CHECK)
Free_Series(hser);
if (!first_pass) break;
first_pass = FALSE;
// Iterate over second series?
//
if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
const REBVAL *temp = val1;
val1 = val2;
val2 = temp;
}
} while (i);
if (hret)
Free_Series(hret);
out_ser = ARR_SERIES(Copy_Array_Shallow(AS_ARRAY(buffer), SPECIFIED));
SET_SERIES_LEN(buffer, 0); // required - allow reuse
}
else {
REB_MOLD mo;
CLEARS(&mo);
if (IS_BINARY(val1)) {
//
// All binaries use "case-sensitive" comparison (e.g. each byte
// is treated distinctly)
//
cased = TRUE;
}
// ask mo.series to have at least `i` capacity beyond mo.start
//
mo.opts = MOPT_RESERVE;
mo.reserve = i;
Push_Mold(&mo);
do {
REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass!
REBUNI uc;
// Iterate over first series
//
i = VAL_INDEX(val1);
for (; i < SER_LEN(ser); i += skip) {
uc = GET_ANY_CHAR(ser, i);
if (flags & SOP_FLAG_CHECK) {
h = (NOT_FOUND != Find_Str_Char(
uc,
VAL_SERIES(val2),
0,
VAL_INDEX(val2),
VAL_LEN_HEAD(val2),
skip,
cased ? AM_FIND_CASE : 0
));
if (flags & SOP_FLAG_INVERT) h = !h;
}
if (!h) continue;
if (
NOT_FOUND == Find_Str_Char(
uc, // c2 (the character to find)
mo.series, // ser
mo.start, // head
mo.start, // index
SER_LEN(mo.series), // tail
skip, // skip
cased ? AM_FIND_CASE : 0 // flags
)
) {
Append_String(mo.series, ser, i, skip);
}
}
if (!first_pass) break;
first_pass = FALSE;
// Iterate over second series?
//
if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
const REBVAL *temp = val1;
val1 = val2;
val2 = temp;
}
} while (i);
out_ser = Pop_Molded_String(&mo);
}
return out_ser;
}
//
// Serial_Actor: C
//
static REB_R Serial_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
REBREQ *req; // 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
REBVAL *path;
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
// Validate PORT fields:
spec = CTX_VAR(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) fail (Error(RE_INVALID_PORT));
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) fail (Error(RE_INVALID_SPEC, spec));
//if (!IS_FILE(path)) fail (Error(RE_INVALID_SPEC, path));
req = cast(REBREQ*, Use_Port_State(port, RDI_SERIAL, sizeof(*req)));
// Actions for an unopened serial port:
if (!IS_OPEN(req)) {
switch (action) {
case SYM_OPEN:
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PATH);
if (! (IS_FILE(arg) || IS_STRING(arg) || IS_BINARY(arg)))
fail (Error(RE_INVALID_PORT_ARG, arg));
req->special.serial.path = ALLOC_N(REBCHR, MAX_SERIAL_DEV_PATH);
OS_STRNCPY(
req->special.serial.path,
//
// !!! This is assuming VAL_DATA contains native chars.
// Should it? (2 bytes on windows, 1 byte on linux/mac)
//
SER_AT(REBCHR, VAL_SERIES(arg), VAL_INDEX(arg)),
MAX_SERIAL_DEV_PATH
);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_SPEED);
if (! IS_INTEGER(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
req->special.serial.baud = VAL_INT32(arg);
//Secure_Port(SYM_SERIAL, ???, path, ser);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_DATA_SIZE);
if (!IS_INTEGER(arg)
|| VAL_INT64(arg) < 5
|| VAL_INT64(arg) > 8
) {
fail (Error(RE_INVALID_PORT_ARG, arg));
}
req->special.serial.data_bits = VAL_INT32(arg);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_STOP_BITS);
if (!IS_INTEGER(arg)
|| VAL_INT64(arg) < 1
|| VAL_INT64(arg) > 2
) {
fail (Error(RE_INVALID_PORT_ARG, arg));
}
req->special.serial.stop_bits = VAL_INT32(arg);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PARITY);
if (IS_BLANK(arg)) {
req->special.serial.parity = SERIAL_PARITY_NONE;
} else {
if (!IS_WORD(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
switch (VAL_WORD_SYM(arg)) {
case SYM_ODD:
req->special.serial.parity = SERIAL_PARITY_ODD;
break;
case SYM_EVEN:
req->special.serial.parity = SERIAL_PARITY_EVEN;
break;
default:
fail (Error(RE_INVALID_PORT_ARG, arg));
}
}
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_FLOW_CONTROL);
if (IS_BLANK(arg)) {
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_NONE;
} else {
if (!IS_WORD(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
switch (VAL_WORD_SYM(arg)) {
case SYM_HARDWARE:
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_HARDWARE;
break;
case SYM_SOFTWARE:
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_SOFTWARE;
break;
default:
fail (Error(RE_INVALID_PORT_ARG, arg));
}
}
if (OS_DO_DEVICE(req, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
SET_OPEN(req);
return R_OUT;
case SYM_CLOSE:
return R_OUT;
case SYM_OPEN_Q:
return R_FALSE;
default:
fail (Error_On_Port(RE_NOT_OPEN, port, -12));
}
}
// Actions for an open socket:
switch (action) {
case SYM_READ:
refs = Find_Refines(frame_, ALL_READ_REFS);
// Setup the read buffer (allocate a buffer if needed):
arg = CTX_VAR(port, STD_PORT_DATA);
if (!IS_STRING(arg) && !IS_BINARY(arg)) {
Val_Init_Binary(arg, Make_Binary(32000));
}
ser = VAL_SERIES(arg);
req->length = SER_AVAIL(ser); // space available
if (req->length < 32000/2) Extend_Series(ser, 32000);
req->length = SER_AVAIL(ser);
// This used STR_TAIL (obsolete, equivalent to BIN_TAIL) but was it
// sure the series was byte sized? Added in a check.
assert(BYTE_SIZE(ser));
req->common.data = BIN_TAIL(ser); // write at tail
//if (SER_LEN(ser) == 0)
req->actual = 0; // Actual for THIS read, not for total.
#ifdef DEBUG_SERIAL
printf("(max read length %d)", req->length);
#endif
result = OS_DO_DEVICE(req, RDC_READ); // recv can happen immediately
if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error));
#ifdef DEBUG_SERIAL
for (len = 0; len < req->actual; len++) {
if (len % 16 == 0) printf("\n");
printf("%02x ", req->common.data[len]);
}
printf("\n");
#endif
*D_OUT = *arg;
return R_OUT;
case SYM_WRITE:
refs = Find_Refines(frame_, ALL_WRITE_REFS);
// Determine length. Clip /PART to size of string if needed.
spec = D_ARG(2);
len = VAL_LEN_AT(spec);
if (refs & AM_WRITE_PART) {
REBCNT n = Int32s(D_ARG(ARG_WRITE_LIMIT), 0);
if (n <= len) len = n;
}
// Setup the write:
*CTX_VAR(port, STD_PORT_DATA) = *spec; // keep it GC safe
req->length = len;
req->common.data = VAL_BIN_AT(spec);
req->actual = 0;
//Print("(write length %d)", len);
result = OS_DO_DEVICE(req, RDC_WRITE); // send can happen immediately
if (result < 0) fail (Error_On_Port(RE_WRITE_ERROR, port, req->error));
break;
case SYM_UPDATE:
// Update the port object after a READ or WRITE operation.
// This is normally called by the WAKE-UP function.
arg = CTX_VAR(port, STD_PORT_DATA);
if (req->command == RDC_READ) {
if (ANY_BINSTR(arg)) {
SET_SERIES_LEN(
VAL_SERIES(arg),
VAL_LEN_HEAD(arg) + req->actual
);
}
}
else if (req->command == RDC_WRITE) {
SET_BLANK(arg); // Write is done.
}
return R_BLANK;
case SYM_OPEN_Q:
return R_TRUE;
case SYM_CLOSE:
if (IS_OPEN(req)) {
OS_DO_DEVICE(req, RDC_CLOSE);
SET_CLOSED(req);
}
break;
default:
fail (Error_Illegal_Action(REB_PORT, action));
}
return R_OUT;
}
//
// Series_Common_Action_Returns: C
//
// This routine is called to handle actions on ANY-SERIES! that can be taken
// care of without knowing what specific kind of series it is. So generally
// index manipulation, and things like LENGTH/etc.
//
// The strange name is to convey the result in an if statement, in the same
// spirit as the `if (XXX_Throws(...)) { /* handle throw */ }` pattern.
//
REBOOL Series_Common_Action_Returns(
REB_R *r, // `r_out` would be slightly confusing, considering R_OUT
REBFRM *frame_,
REBSYM action
) {
REBVAL *value = D_ARG(1);
REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
REBINT index = cast(REBINT, VAL_INDEX(value));
REBINT tail = cast(REBINT, VAL_LEN_HEAD(value));
REBINT len = 0;
switch (action) {
//-- Navigation:
case SYM_HEAD:
VAL_INDEX(value) = 0;
break;
case SYM_TAIL:
VAL_INDEX(value) = (REBCNT)tail;
break;
case SYM_HEAD_Q:
*r = (index == 0) ? R_TRUE : R_FALSE;
return TRUE; // handled
case SYM_TAIL_Q:
*r = (index >= tail) ? R_TRUE : R_FALSE;
return TRUE; // handled
case SYM_PAST_Q:
*r = (index > tail) ? R_TRUE : R_FALSE;
return TRUE; // handled
case SYM_NEXT:
if (index < tail) VAL_INDEX(value)++;
break;
case SYM_BACK:
if (index > 0) VAL_INDEX(value)--;
break;
case SYM_SKIP:
case SYM_AT:
len = Get_Num_From_Arg(arg);
{
REBI64 i = (REBI64)index + (REBI64)len;
if (action == SYM_SKIP) {
if (IS_LOGIC(arg)) i--;
} else { // A_AT
if (len > 0) i--;
}
if (i > (REBI64)tail) i = (REBI64)tail;
else if (i < 0) i = 0;
VAL_INDEX(value) = (REBCNT)i;
}
break;
case SYM_INDEX_OF:
SET_INTEGER(D_OUT, cast(REBI64, index) + 1);
*r = R_OUT;
return TRUE; // handled
case SYM_LENGTH:
SET_INTEGER(D_OUT, tail > index ? tail - index : 0);
*r = R_OUT;
return TRUE; // handled
case SYM_REMOVE:
// /PART length
FAIL_IF_LOCKED_SERIES(VAL_SERIES(value));
len = D_REF(2) ? Partial(value, 0, D_ARG(3)) : 1;
index = cast(REBINT, VAL_INDEX(value));
if (index < tail && len != 0)
Remove_Series(VAL_SERIES(value), VAL_INDEX(value), len);
break;
case SYM_ADD: // Join_Strings(value, arg);
case SYM_SUBTRACT: // "test this" - 10
case SYM_MULTIPLY: // "t" * 4 = "tttt"
case SYM_DIVIDE:
case SYM_REMAINDER:
case SYM_POWER:
case SYM_ODD_Q:
case SYM_EVEN_Q:
case SYM_ABSOLUTE:
fail (Error_Illegal_Action(VAL_TYPE(value), action));
default:
return FALSE; // not a common operation, not handled
}
*D_OUT = *value;
*r = R_OUT;
return TRUE; // handled
}
static REBSER *make_binary(const REBVAL *arg, REBOOL make)
{
REBSER *ser;
// MAKE BINARY! 123
switch (VAL_TYPE(arg)) {
case REB_INTEGER:
case REB_DECIMAL:
if (make) ser = Make_Binary(Int32s(arg, 0));
else ser = Make_Binary_BE64(arg);
break;
// MAKE/TO BINARY! BINARY!
case REB_BINARY:
ser = Copy_Bytes(VAL_BIN_AT(arg), VAL_LEN_AT(arg));
break;
// MAKE/TO BINARY! <any-string>
case REB_STRING:
case REB_FILE:
case REB_EMAIL:
case REB_URL:
case REB_TAG:
// case REB_ISSUE:
ser = Make_UTF8_From_Any_String(arg, VAL_LEN_AT(arg), 0);
break;
case REB_BLOCK:
// Join_Binary returns a shared buffer, so produce a copy:
ser = Copy_Sequence(Join_Binary(arg, -1));
break;
// MAKE/TO BINARY! <tuple!>
case REB_TUPLE:
ser = Copy_Bytes(VAL_TUPLE(arg), VAL_TUPLE_LEN(arg));
break;
// MAKE/TO BINARY! <char!>
case REB_CHAR:
ser = Make_Binary(6);
TERM_SEQUENCE_LEN(ser, Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg)));
break;
// MAKE/TO BINARY! <bitset!>
case REB_BITSET:
ser = Copy_Bytes(VAL_BIN(arg), VAL_LEN_HEAD(arg));
break;
// MAKE/TO BINARY! <image!>
case REB_IMAGE:
ser = Make_Image_Binary(arg);
break;
case REB_MONEY:
ser = Make_Binary(12);
deci_to_binary(BIN_HEAD(ser), VAL_MONEY_AMOUNT(arg));
TERM_SEQUENCE_LEN(ser, 12);
break;
default:
ser = 0;
}
return ser;
}
//
// Mold_Vector: C
//
void Mold_Vector(const REBVAL *value, REB_MOLD *mold, REBOOL molded)
{
REBSER *vect = VAL_SERIES(value);
REBYTE *data = SER_DATA_RAW(vect);
REBCNT bits = VECT_TYPE(vect);
// REBCNT dims = vect->size >> 8;
REBCNT len;
REBCNT n;
REBCNT c;
union {REBU64 i; REBDEC d;} v;
REBYTE buf[32];
REBYTE l;
if (GET_MOPT(mold, MOPT_MOLD_ALL)) {
len = VAL_LEN_HEAD(value);
n = 0;
} else {
len = VAL_LEN_AT(value);
n = VAL_INDEX(value);
}
if (molded) {
enum Reb_Kind kind = (bits >= VTSF08) ? REB_DECIMAL : REB_INTEGER;
Pre_Mold(value, mold);
if (!GET_MOPT(mold, MOPT_MOLD_ALL))
Append_Codepoint_Raw(mold->series, '[');
if (bits >= VTUI08 && bits <= VTUI64)
Append_Unencoded(mold->series, "unsigned ");
Emit(
mold,
"N I I [",
Canon(SYM_FROM_KIND(kind)),
bit_sizes[bits & 3],
len
);
if (len)
New_Indented_Line(mold);
}
c = 0;
for (; n < SER_LEN(vect); n++) {
v.i = get_vect(bits, data, n);
if (bits < VTSF08) {
l = Emit_Integer(buf, v.i);
} else {
l = Emit_Decimal(buf, v.d, 0, '.', mold->digits);
}
Append_Unencoded_Len(mold->series, s_cast(buf), l);
if ((++c > 7) && (n + 1 < SER_LEN(vect))) {
New_Indented_Line(mold);
c = 0;
}
else
Append_Codepoint_Raw(mold->series, ' ');
}
if (len) {
//
// remove final space (overwritten with terminator)
//
TERM_UNI_LEN(mold->series, UNI_LEN(mold->series) - 1);
}
if (molded) {
if (len) New_Indented_Line(mold);
Append_Codepoint_Raw(mold->series, ']');
if (!GET_MOPT(mold, MOPT_MOLD_ALL)) {
Append_Codepoint_Raw(mold->series, ']');
}
else {
Post_Mold(value, mold);
}
}
}
