//
// Make_Bitset: C
//
// Return a bitset series (binary.
//
// len: the # of bits in the bitset.
//
REBSER *Make_Bitset(REBCNT len)
{
REBSER *ser;
len = (len + 7) / 8;
ser = Make_Binary(len);
Clear_Series(ser);
SET_SERIES_LEN(ser, len);
BITS_NOT(ser) = FALSE;
return ser;
}
//
// Trim_Tail: C
//
// Used to trim off hanging spaces during FORM and MOLD.
//
void Trim_Tail(REBSER *src, REBYTE chr)
{
REBOOL unicode = NOT(BYTE_SIZE(src));
REBCNT tail;
REBUNI c;
assert(!Is_Array_Series(src));
for (tail = SER_LEN(src); tail > 0; tail--) {
c = unicode ? *UNI_AT(src, tail - 1) : *BIN_AT(src, tail - 1);
if (c != chr) break;
}
SET_SERIES_LEN(src, tail);
TERM_SEQUENCE(src);
}
//
// Entab_Unicode: C
//
// Entab a string and return a new series.
//
REBSER *Entab_Unicode(REBUNI *bp, REBCNT index, REBCNT len, REBINT tabsize)
{
REBINT n = 0;
REBUNI *dp;
REBUNI c;
REB_MOLD mo;
CLEARS(&mo);
mo.opts = MOPT_RESERVE;
mo.reserve = len;
Push_Mold(&mo);
dp = UNI_AT(mo.series, mo.start);
for (; index < len; index++) {
c = bp[index];
// Count leading spaces, insert TAB for each tabsize:
if (c == ' ') {
if (++n >= tabsize) {
*dp++ = '\t';
n = 0;
}
continue;
}
// Hitting a leading TAB resets space counter:
if (c == '\t') {
*dp++ = (REBYTE)c;
n = 0;
}
else {
// Incomplete tab space, pad with spaces:
for (; n > 0; n--) *dp++ = ' ';
// Copy chars thru end-of-line (or end of buffer):
while (index < len) {
if ((*dp++ = bp[index++]) == '\n') break;
}
}
}
SET_SERIES_LEN(mo.series, mo.start + cast(REBCNT, dp - UNI_AT(mo.series, mo.start)));
UNI_TERM(mo.series);
return Pop_Molded_String(&mo);
}
//
// Complement_Binary: C
//
// Only valid for BINARY data.
//
REBSER *Complement_Binary(REBVAL *value)
{
REBSER *series;
REBYTE *str = VAL_BIN_AT(value);
REBINT len = VAL_LEN_AT(value);
REBYTE *out;
series = Make_Binary(len);
SET_SERIES_LEN(series, len);
out = BIN_HEAD(series);
for (; len > 0; len--) {
*out++ = ~(*str);
++str;
}
return series;
}
//
// Decode_Base2: C
//
static REBSER *Decode_Base2(const REBYTE **src, REBCNT len, REBYTE delim)
{
REBYTE *bp;
const REBYTE *cp;
REBCNT count = 0;
REBCNT accum = 0;
REBYTE lex;
REBSER *ser;
ser = Make_Binary(len >> 3);
bp = BIN_HEAD(ser);
cp = *src;
for (; len > 0; cp++, len--) {
if (delim && *cp == delim) break;
lex = Lex_Map[*cp];
if (lex >= LEX_NUMBER) {
if (*cp == '0') accum *= 2;
else if (*cp == '1') accum = (accum * 2) + 1;
else goto err;
if (count++ >= 7) {
*bp++ = cast(REBYTE, accum);
count = 0;
accum = 0;
}
}
else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
}
if (count) goto err; // improper modulus
*bp = 0;
SET_SERIES_LEN(ser, bp - BIN_HEAD(ser));
ASSERT_SERIES_TERM(ser);
return ser;
err:
Free_Series(ser);
*src = cp;
return 0;
}
//
// Detab_Unicode: C
//
// Detab a unicode string and return a new series.
//
REBSER *Detab_Unicode(REBUNI *bp, REBCNT index, REBCNT len, REBINT tabsize)
{
REBCNT cnt = 0;
REBCNT n;
REBUNI *dp;
REBUNI c;
REB_MOLD mo;
CLEARS(&mo);
// Estimate new length based on tab expansion:
for (n = index; n < len; n++)
if (bp[n] == TAB) cnt++;
mo.opts = MOPT_RESERVE;
mo.reserve = len + (cnt * (tabsize - 1));
Push_Mold(&mo);
dp = UNI_AT(mo.series, mo.start);
n = 0;
while (index < len) {
c = bp[index++];
if (c == '\t') {
*dp++ = ' ';
n++;
for (; n % tabsize != 0; n++) *dp++ = ' ';
continue;
}
if (c == '\n') n = 0;
else n++;
*dp++ = c;
}
SET_SERIES_LEN(mo.series, mo.start + cast(REBCNT, dp - UNI_AT(mo.series, mo.start)));
UNI_TERM(mo.series);
return Pop_Molded_String(&mo);
}
//
// Decode_Base16: C
//
static REBSER *Decode_Base16(const REBYTE **src, REBCNT len, REBYTE delim)
{
REBYTE *bp;
const REBYTE *cp;
REBCNT count = 0;
REBCNT accum = 0;
REBYTE lex;
REBINT val;
REBSER *ser;
ser = Make_Binary(len / 2);
bp = BIN_HEAD(ser);
cp = *src;
for (; len > 0; cp++, len--) {
if (delim && *cp == delim) break;
lex = Lex_Map[*cp];
if (lex > LEX_WORD) {
val = lex & LEX_VALUE; // char num encoded into lex
if (!val && lex < LEX_NUMBER) goto err; // invalid char (word but no val)
accum = (accum << 4) + val;
if (count++ & 1) *bp++ = cast(REBYTE, accum);
}
else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
}
if (count & 1) goto err; // improper modulus
*bp = 0;
SET_SERIES_LEN(ser, bp - BIN_HEAD(ser));
ASSERT_SERIES_TERM(ser);
return ser;
err:
Free_Series(ser);
*src = cp;
return 0;
}
//
// Make_Vector: C
//
// type: the datatype
// sign: signed or unsigned
// dims: number of dimensions
// bits: number of bits per unit (8, 16, 32, 64)
// size: size of array ?
//
REBSER *Make_Vector(REBINT type, REBINT sign, REBINT dims, REBINT bits, REBINT size)
{
REBCNT len;
REBSER *ser;
len = size * dims;
if (len > 0x7fffffff) return 0;
// !!! can width help extend the len?
ser = Make_Series(len + 1, bits/8, MKS_NONE | MKS_POWER_OF_2);
CLEAR(SER_DATA_RAW(ser), (len * bits) / 8);
SET_SERIES_LEN(ser, len);
// Store info about the vector (could be moved to flags if necessary):
switch (bits) {
case 8: bits = 0; break;
case 16: bits = 1; break;
case 32: bits = 2; break;
case 64: bits = 3; break;
}
ser->misc.size = (dims << 8) | (type << 3) | (sign << 2) | bits;
return ser;
}
static REBSER *Make_Binary_BE64(const REBVAL *arg)
{
REBSER *ser = Make_Binary(9);
REBI64 n;
REBINT count;
REBYTE *bp = BIN_HEAD(ser);
if (IS_INTEGER(arg)) {
n = VAL_INT64(arg);
}
else {
assert(IS_DECIMAL(arg));
n = VAL_DECIMAL_BITS(arg);
}
for (count = 7; count >= 0; count--) {
bp[count] = (REBYTE)(n & 0xff);
n >>= 8;
}
bp[8] = 0;
SET_SERIES_LEN(ser, 8);
return ser;
}
//
// Modify_String: C
//
// Returns new dst_idx.
//
REBCNT Modify_String(
REBCNT action, // INSERT, APPEND, CHANGE
REBSER *dst_ser, // target
REBCNT dst_idx, // position
const REBVAL *src_val, // source
REBFLGS flags, // AN_PART
REBINT dst_len, // length to remove
REBINT dups // dup count
) {
REBSER *src_ser = 0;
REBCNT src_idx = 0;
REBCNT src_len;
REBCNT tail = SER_LEN(dst_ser);
REBINT size; // total to insert
REBOOL needs_free;
REBINT limit;
// For INSERT/PART and APPEND/PART
if (action != SYM_CHANGE && GET_FLAG(flags, AN_PART))
limit = dst_len; // should be non-negative
else
limit = -1;
if (limit == 0 || dups < 0) return (action == SYM_APPEND) ? 0 : dst_idx;
if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail;
// If the src_val is not a string, then we need to create a string:
if (GET_FLAG(flags, AN_SERIES)) { // used to indicate a BINARY series
if (IS_INTEGER(src_val)) {
src_ser = Make_Series_Codepoint(Int8u(src_val));
needs_free = TRUE;
limit = -1;
}
else if (IS_BLOCK(src_val)) {
src_ser = Join_Binary(src_val, limit); // NOTE: it's the shared FORM buffer!
needs_free = FALSE;
limit = -1;
}
else if (IS_CHAR(src_val)) {
//
// "UTF-8 was originally specified to allow codepoints with up to
// 31 bits (or 6 bytes). But with RFC3629, this was reduced to 4
// bytes max. to be more compatible to UTF-16." So depending on
// which RFC you consider "the UTF-8", max size is either 4 or 6.
//
src_ser = Make_Binary(6);
SET_SERIES_LEN(
src_ser,
Encode_UTF8_Char(BIN_HEAD(src_ser), VAL_CHAR(src_val))
);
needs_free = TRUE;
limit = -1;
}
else if (ANY_STRING(src_val)) {
src_len = VAL_LEN_AT(src_val);
if (limit >= 0 && src_len > cast(REBCNT, limit))
src_len = limit;
src_ser = Make_UTF8_From_Any_String(src_val, src_len, 0);
needs_free = TRUE;
limit = -1;
}
else if (!IS_BINARY(src_val))
fail (Error_Invalid_Arg(src_val));
}
else if (IS_CHAR(src_val)) {
src_ser = Make_Series_Codepoint(VAL_CHAR(src_val));
needs_free = TRUE;
}
else if (IS_BLOCK(src_val)) {
src_ser = Form_Tight_Block(src_val);
needs_free = TRUE;
}
else if (!ANY_STRING(src_val) || IS_TAG(src_val)) {
src_ser = Copy_Form_Value(src_val, 0);
needs_free = TRUE;
}
// Use either new src or the one that was passed:
if (src_ser) {
src_len = SER_LEN(src_ser);
}
else {
src_ser = VAL_SERIES(src_val);
src_idx = VAL_INDEX(src_val);
src_len = VAL_LEN_AT(src_val);
needs_free = FALSE;
}
if (limit >= 0) src_len = limit;
// If Source == Destination we need to prevent possible conflicts.
// Clone the argument just to be safe.
// (Note: It may be possible to optimize special cases like append !!)
if (dst_ser == src_ser) {
assert(!needs_free);
src_ser = Copy_Sequence_At_Len(src_ser, src_idx, src_len);
needs_free = TRUE;
src_idx = 0;
}
// Total to insert:
size = dups * src_len;
if (action != SYM_CHANGE) {
// Always expand dst_ser for INSERT and APPEND actions:
Expand_Series(dst_ser, dst_idx, size);
} else {
if (size > dst_len)
Expand_Series(dst_ser, dst_idx, size - dst_len);
else if (size < dst_len && GET_FLAG(flags, AN_PART))
Remove_Series(dst_ser, dst_idx, dst_len - size);
else if (size + dst_idx > tail) {
EXPAND_SERIES_TAIL(dst_ser, size - (tail - dst_idx));
}
}
// For dup count:
for (; dups > 0; dups--) {
Insert_String(dst_ser, dst_idx, src_ser, src_idx, src_len, TRUE);
dst_idx += src_len;
}
TERM_SEQUENCE(dst_ser);
if (needs_free) {
// If we did not use the series that was passed in, but rather
// created an internal temporary one, we need to free it.
Free_Series(src_ser);
}
return (action == SYM_APPEND) ? 0 : dst_idx;
}
//
// 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;
}
//
// Extend_Series: C
//
// Extend a series at its end without affecting its tail index.
//
void Extend_Series(REBSER *s, REBCNT delta)
{
REBCNT len_old = SER_LEN(s);
EXPAND_SERIES_TAIL(s, delta);
SET_SERIES_LEN(s, len_old);
}
//
// Xandor_Binary: C
//
// Only valid for BINARY data.
//
REBSER *Xandor_Binary(REBCNT action, REBVAL *value, REBVAL *arg)
{
REBSER *series;
REBYTE *p0 = VAL_BIN_AT(value);
REBYTE *p1 = VAL_BIN_AT(arg);
REBYTE *p2;
REBCNT i;
REBCNT mt, t1, t0, t2;
t0 = VAL_LEN_AT(value);
t1 = VAL_LEN_AT(arg);
mt = MIN(t0, t1); // smaller array size
// For AND - result is size of shortest input:
// if (action == A_AND || (action == 0 && t1 >= t0))
// t2 = mt;
// else
t2 = MAX(t0, t1);
if (IS_BITSET(value)) {
//
// Although bitsets and binaries share some implementation here,
// they have distinct allocation functions...and bitsets need
// to set the REBSER.misc.negated union field (BITS_NOT) as
// it would be illegal to read it if it were cleared via another
// element of the union.
//
assert(IS_BITSET(arg));
series = Make_Bitset(t2 * 8);
}
else {
// Ordinary binary
//
series = Make_Binary(t2);
SET_SERIES_LEN(series, t2);
}
p2 = BIN_HEAD(series);
switch (action) {
case SYM_AND_T: // and~
for (i = 0; i < mt; i++) *p2++ = *p0++ & *p1++;
CLEAR(p2, t2 - mt);
return series;
case SYM_OR_T: // or~
for (i = 0; i < mt; i++) *p2++ = *p0++ | *p1++;
break;
case SYM_XOR_T: // xor~
for (i = 0; i < mt; i++) *p2++ = *p0++ ^ *p1++;
break;
default:
// special bit set case EXCLUDE:
for (i = 0; i < mt; i++) *p2++ = *p0++ & ~*p1++;
if (t0 > t1) memcpy(p2, p0, t0 - t1); // residual from first only
return series;
}
// Copy the residual:
memcpy(p2, ((t0 > t1) ? p0 : p1), t2 - mt);
return series;
}
//
// RL_Set_Series_Len: C
//
// Returns:
// A pointer to an image series, or zero if size is too large.
// Arguments:
// width - the width of the image in pixels
// height - the height of the image in lines
// Notes:
// Expedient replacement for a line of code related to PNG loading
// in %host-core.c that said "hack! - will set the tail to buffersize"
//
// *((REBCNT*)(binary+1)) = buffersize;
//
RL_API void RL_Set_Series_Len(REBSER* series, REBCNT len)
{
SET_SERIES_LEN(series, len);
}
//
// 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;
}
