//
// Find_Key: C
//
// Returns hash index (either the match or the new one).
// A return of zero is valid (as a hash index);
//
// Wide: width of record (normally 2, a key and a value).
//
// Modes:
// 0 - search, return hash if found or not
// 1 - search, return hash, else return -1 if not
// 2 - search, return hash, else append value and return -1
//
REBINT Find_Key(REBSER *series, REBSER *hser, const REBVAL *key, REBINT wide, REBCNT cased, REBYTE mode)
{
REBCNT *hashes;
REBCNT skip;
REBCNT hash;
REBCNT len;
REBCNT n;
REBVAL *val;
// Compute hash for value:
len = hser->tail;
hash = Hash_Value(key, len);
if (!hash) fail (Error_Has_Bad_Type(key));
// Determine skip and first index:
skip = (len == 0) ? 0 : (hash & 0x0000FFFF) % len;
if (skip == 0) skip = 1;
hash = (len == 0) ? 0 : (hash & 0x00FFFF00) % len;
// Scan hash table for match:
hashes = (REBCNT*)hser->data;
if (ANY_WORD(key)) {
while ((n = hashes[hash])) {
val = BLK_SKIP(series, (n-1) * wide);
if (
ANY_WORD(val) &&
(VAL_WORD_SYM(key) == VAL_WORD_SYM(val) ||
(!cased && VAL_WORD_CANON(key) == VAL_WORD_CANON(val)))
) return hash;
hash += skip;
if (hash >= len) hash -= len;
}
}
else if (ANY_BINSTR(key)) {
while ((n = hashes[hash])) {
val = BLK_SKIP(series, (n-1) * wide);
if (
VAL_TYPE(val) == VAL_TYPE(key)
&& 0 == Compare_String_Vals(key, val, (REBOOL)(!IS_BINARY(key) && !cased))
) return hash;
hash += skip;
if (hash >= len) hash -= len;
}
} else {
while ((n = hashes[hash])) {
val = BLK_SKIP(series, (n-1) * wide);
if (VAL_TYPE(val) == VAL_TYPE(key) && 0 == Cmp_Value(key, val, !cased)) return hash;
hash += skip;
if (hash >= len) hash -= len;
}
}
// Append new value the target series:
if (mode > 1) {
hashes[hash] = SERIES_TAIL(series) + 1;
Append_Values_Len(series, key, wide);
}
return (mode > 0) ? NOT_FOUND : hash;
}
static REBCNT find_string(REBSER *series, REBCNT index, REBCNT end, REBVAL *target, REBCNT len, REBCNT flags, REBINT skip)
{
REBCNT start = index;
if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
skip = -1;
start = 0;
if (flags & AM_FIND_LAST) index = end - len;
else index--;
}
if (ANY_BINSTR(target)) {
// Do the optimal search or the general search?
if (BYTE_SIZE(series) && VAL_BYTE_SIZE(target) && !(flags & ~(AM_FIND_CASE|AM_FIND_MATCH)))
return Find_Byte_Str(series, start, VAL_BIN_DATA(target), len, !GET_FLAG(flags, ARG_FIND_CASE-1), GET_FLAG(flags, ARG_FIND_MATCH-1));
else
return Find_Str_Str(series, start, index, end, skip, VAL_SERIES(target), VAL_INDEX(target), len, flags & (AM_FIND_MATCH|AM_FIND_CASE));
}
else if (IS_BINARY(target)) {
return Find_Byte_Str(series, start, VAL_BIN_DATA(target), len, 0, GET_FLAG(flags, ARG_FIND_MATCH-1));
}
else if (IS_CHAR(target)) {
return Find_Str_Char(series, start, index, end, skip, VAL_CHAR(target), flags);
}
else if (IS_INTEGER(target)) {
return Find_Str_Char(series, start, index, end, skip, (REBUNI)VAL_INT32(target), flags);
}
else if (IS_BITSET(target)) {
return Find_Str_Bitset(series, start, index, end, skip, VAL_SERIES(target), flags);
}
return NOT_FOUND;
}
//
// MAKE_String: C
//
void MAKE_String(REBVAL *out, enum Reb_Kind kind, const REBVAL *def) {
REBSER *ser; // goto would cross initialization
if (IS_INTEGER(def)) {
//
// !!! R3-Alpha tolerated decimal, e.g. `make string! 3.14`, which
// is semantically nebulous (round up, down?) and generally bad.
//
ser = Make_Binary(Int32s(def, 0));
Val_Init_Series(out, kind, ser);
return;
}
else if (IS_BLOCK(def)) {
//
// The construction syntax for making strings or binaries that are
// preloaded with an offset into the data is #[binary [#{0001} 2]].
// In R3-Alpha make definitions didn't have to be a single value
// (they are for compatibility between construction syntax and MAKE
// in Ren-C). So the positional syntax was #[binary! #{0001} 2]...
// while #[binary [#{0001} 2]] would join the pieces together in order
// to produce #{000102}. That behavior is not available in Ren-C.
if (VAL_ARRAY_LEN_AT(def) != 2)
goto bad_make;
RELVAL *any_binstr = VAL_ARRAY_AT(def);
if (!ANY_BINSTR(any_binstr))
goto bad_make;
if (IS_BINARY(any_binstr) != LOGICAL(kind == REB_BINARY))
goto bad_make;
RELVAL *index = VAL_ARRAY_AT(def) + 1;
if (!IS_INTEGER(index))
goto bad_make;
REBINT i = Int32(index) - 1 + VAL_INDEX(any_binstr);
if (i < 0 || i > cast(REBINT, VAL_LEN_AT(any_binstr)))
goto bad_make;
Val_Init_Series_Index(out, kind, VAL_SERIES(any_binstr), i);
return;
}
if (kind == REB_BINARY)
ser = make_binary(def, TRUE);
else
ser = MAKE_TO_String_Common(def);
if (!ser)
goto bad_make;
Val_Init_Series_Index(out, kind, ser, 0);
return;
bad_make:
fail (Error_Bad_Make(kind, def));
}
*/ REBINT PD_String(REBPVS *pvs)
/*
***********************************************************************/
{
REBVAL *data = pvs->value;
REBVAL *val = pvs->setval;
REBINT n = 0;
REBCNT i;
REBINT c;
REBSER *ser = VAL_SERIES(data);
if (IS_INTEGER(pvs->select)) {
n = Int32(pvs->select) + VAL_INDEX(data) - 1;
}
else return PE_BAD_SELECT;
if (val == 0) {
if (n < 0 || (REBCNT)n >= SERIES_TAIL(ser)) return PE_NONE;
if (IS_BINARY(data)) {
SET_INTEGER(pvs->store, *BIN_SKIP(ser, n));
} else {
SET_CHAR(pvs->store, GET_ANY_CHAR(ser, n));
}
return PE_USE;
}
if (n < 0 || (REBCNT)n >= SERIES_TAIL(ser)) return PE_BAD_RANGE;
if (IS_CHAR(val)) {
c = VAL_CHAR(val);
if (c > MAX_CHAR) return PE_BAD_SET;
}
else if (IS_INTEGER(val)) {
c = Int32(val);
if (c > MAX_CHAR || c < 0) return PE_BAD_SET;
if (IS_BINARY(data)) { // special case for binary
if (c > 0xff) Trap_Range(val);
BIN_HEAD(ser)[n] = (REBYTE)c;
return PE_OK;
}
}
else if (ANY_BINSTR(val)) {
i = VAL_INDEX(val);
if (i >= VAL_TAIL(val)) return PE_BAD_SET;
c = GET_ANY_CHAR(VAL_SERIES(val), i);
}
else
return PE_BAD_SELECT;
TRAP_PROTECT(ser);
if (BYTE_SIZE(ser) && c > 0xff) Widen_String(ser);
SET_ANY_CHAR(ser, n, c);
return PE_OK;
}
*/ 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;
}
*/ REBFLG MT_String(REBVAL *out, REBVAL *data, REBCNT type)
/*
***********************************************************************/
{
REBCNT i;
if (!ANY_BINSTR(data)) return FALSE;
*out = *data++;
VAL_SET(out, type);
i = IS_INTEGER(data) ? Int32(data) - 1 : 0;
if (i > VAL_TAIL(out)) i = VAL_TAIL(out); // clip it
VAL_INDEX(out) = i;
return TRUE;
}
static REBSER *make_string(REBVAL *arg, REBOOL make)
{
REBSER *ser = 0;
// MAKE <type> 123
if (make && (IS_INTEGER(arg) || IS_DECIMAL(arg))) {
ser = Make_Binary(Int32s(arg, 0));
}
// MAKE/TO <type> <binary!>
else if (IS_BINARY(arg)) {
REBYTE *bp = VAL_BIN_DATA(arg);
REBCNT len = VAL_LEN(arg);
switch (What_UTF(bp, len)) {
case 0:
break;
case 8: // UTF-8 encoded
bp += 3;
len -= 3;
break;
default:
Trap0(RE_BAD_DECODE);
}
ser = Decode_UTF_String(bp, len, 8); // UTF-8
}
// MAKE/TO <type> <any-string>
else if (ANY_BINSTR(arg)) {
ser = Copy_String(VAL_SERIES(arg), VAL_INDEX(arg), VAL_LEN(arg));
}
// MAKE/TO <type> <any-word>
else if (ANY_WORD(arg)) {
ser = Copy_Mold_Value(arg, TRUE);
//ser = Append_UTF8(0, Get_Word_Name(arg), -1);
}
// MAKE/TO <type> #"A"
else if (IS_CHAR(arg)) {
ser = (VAL_CHAR(arg) > 0xff) ? Make_Unicode(2) : Make_Binary(2);
Append_Byte(ser, VAL_CHAR(arg));
}
// MAKE/TO <type> <any-value>
// else if (IS_NONE(arg)) {
// ser = Make_Binary(0);
// }
else
ser = Copy_Form_Value(arg, 1<<MOPT_TIGHT);
return ser;
}
//
// 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;
}
static REBSER *MAKE_TO_String_Common(const REBVAL *arg)
{
REBSER *ser = 0;
// MAKE/TO <type> <binary!>
if (IS_BINARY(arg)) {
REBYTE *bp = VAL_BIN_AT(arg);
REBCNT len = VAL_LEN_AT(arg);
switch (What_UTF(bp, len)) {
case 0:
break;
case 8: // UTF-8 encoded
bp += 3;
len -= 3;
break;
default:
fail (Error(RE_BAD_UTF8));
}
ser = Decode_UTF_String(bp, len, 8); // UTF-8
}
// MAKE/TO <type> <any-string>
else if (ANY_BINSTR(arg)) {
ser = Copy_String_Slimming(VAL_SERIES(arg), VAL_INDEX(arg), VAL_LEN_AT(arg));
}
// MAKE/TO <type> <any-word>
else if (ANY_WORD(arg)) {
ser = Copy_Mold_Value(arg, 0 /* opts... MOPT_0? */);
}
// MAKE/TO <type> #"A"
else if (IS_CHAR(arg)) {
ser = (VAL_CHAR(arg) > 0xff) ? Make_Unicode(2) : Make_Binary(2);
Append_Codepoint_Raw(ser, VAL_CHAR(arg));
}
else
ser = Copy_Form_Value(arg, 1 << MOPT_TIGHT);
return ser;
}
*/ static REBCNT Find_Entry(REBSER *series, REBVAL *key, REBVAL *val)
/*
** 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.
**
***********************************************************************/
{
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(key, 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;
// VAL_SERIES(v) = Copy_Series_Value(val);
// VAL_INDEX(v) = 0;
}
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 Trap_Type_DEAD_END(key);
if (!val) return 0;
Append_Value(series, key);
Append_Value(series, val); // no Copy_Series_Value(val) on strings
return series->tail/2;
}
// Add hash table:
//Print("hash added %d", series->tail);
series->extra.series = hser = Make_Hash_Array(series->tail);
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); // no Copy_Series_Value(val) on strings
return (hashes[hash] = series->tail/2);
}
//
// 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;
}
//
// 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;
}
//
// 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);
}
*/ static REBCNT Parse_To(REBPARSE *parse, REBCNT index, REBVAL *item, REBFLG is_thru)
/*
** Parse TO a specific:
** 1. integer - index position
** 2. END - end of input
** 3. value - according to datatype
** 4. block of values - the first one we hit
**
***********************************************************************/
{
REBSER *series = parse->series;
REBCNT i;
REBSER *ser;
// TO a specific index position.
if (IS_INTEGER(item)) {
i = (REBCNT)Int32(item) - (is_thru ? 0 : 1);
if (i > series->tail) i = series->tail;
}
// END
else if (IS_WORD(item) && VAL_WORD_CANON(item) == SYM_END) {
i = series->tail;
}
else if (IS_BLOCK(item)) {
i = To_Thru(parse, index, item, is_thru);
}
else {
if (IS_BLOCK_INPUT(parse)) {
REBVAL word; /// !!!Temp, but where can we put it?
if (IS_LIT_WORD(item)) { // patch to search for word, not lit.
word = *item;
VAL_SET(&word, REB_WORD);
item = &word;
}
///i = Find_Value(series, index, tail-index, item, 1, (REBOOL)(PF_CASE & flags), FALSE, 1);
i = Find_Block(series, index, series->tail, item, 1, HAS_CASE(parse)?AM_FIND_CASE:0, 1);
if (i != NOT_FOUND && is_thru) i++;
}
else {
// "str"
if (ANY_BINSTR(item)) {
if (!IS_STRING(item) && !IS_BINARY(item)) {
// !!! Can this be optimized not to use COPY?
ser = Copy_Form_Value(item, 0);
i = Find_Str_Str(series, 0, index, series->tail, 1, ser, 0, ser->tail, HAS_CASE(parse));
if (i != NOT_FOUND && is_thru) i += ser->tail;
}
else {
i = Find_Str_Str(series, 0, index, series->tail, 1, VAL_SERIES(item), VAL_INDEX(item), VAL_LEN(item), HAS_CASE(parse));
if (i != NOT_FOUND && is_thru) i += VAL_LEN(item);
}
}
// #"A"
else if (IS_CHAR(item)) {
i = Find_Str_Char(series, 0, index, series->tail, 1, VAL_CHAR(item), HAS_CASE(parse));
if (i != NOT_FOUND && is_thru) i++;
}
}
}
return i;
}
x*/ void Modify_StringX(REBCNT action, REBVAL *string, REBVAL *arg)
/*
** Actions: INSERT, APPEND, CHANGE
**
** string [string!] {Series at point to insert}
** value [any-type!] {The value to insert}
** /part {Limits to a given length or position.}
** length [number! series! pair!]
** /only {Inserts a series as a series.}
** /dup {Duplicates the insert a specified number of times.}
** count [number! pair!]
**
***********************************************************************/
{
REBSER *series = VAL_SERIES(string);
REBCNT index = VAL_INDEX(string);
REBCNT tail = VAL_TAIL(string);
REBINT rlen; // length to be removed
REBINT ilen = 1; // length to be inserted
REBINT cnt = 1; // DUP count
REBINT size;
REBVAL *val;
REBSER *arg_ser = 0; // argument series
// Length of target (may modify index): (arg can be anything)
rlen = Partial1((action == A_CHANGE) ? string : arg, DS_ARG(AN_LENGTH));
index = VAL_INDEX(string);
if (action == A_APPEND || index > tail) index = tail;
// If the arg is not a string, then we need to create a string:
if (IS_BINARY(string)) {
if (IS_INTEGER(arg)) {
if (VAL_INT64(arg) > 255 || VAL_INT64(arg) < 0)
Trap_Range(arg);
arg_ser = Make_Binary(1);
Append_Byte(arg_ser, VAL_CHAR(arg)); // check for size!!!
}
else if (!ANY_BINSTR(arg)) Trap_Arg(arg);
}
else if (IS_BLOCK(arg)) {
// MOVE!
REB_MOLD mo = {0};
arg_ser = mo.series = Make_Unicode(VAL_BLK_LEN(arg) * 10); // GC!?
for (val = VAL_BLK_DATA(arg); NOT_END(val); val++)
Mold_Value(&mo, val, 0);
}
else if (IS_CHAR(arg)) {
// Optimize this case !!!
arg_ser = Make_Unicode(1);
Append_Byte(arg_ser, VAL_CHAR(arg));
}
else if (!ANY_STR(arg) || IS_TAG(arg)) {
arg_ser = Copy_Form_Value(arg, 0);
}
if (arg_ser) Set_String(arg, arg_ser);
else arg_ser = VAL_SERIES(arg);
// Length of insertion:
ilen = (action != A_CHANGE && DS_REF(AN_PART)) ? rlen : VAL_LEN(arg);
// 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 (series == VAL_SERIES(arg)) {
arg_ser = Copy_Series_Part(arg_ser, VAL_INDEX(arg), ilen); // GC!?
}
// Get /DUP count:
if (DS_REF(AN_DUP)) {
cnt = Int32(DS_ARG(AN_COUNT));
if (cnt <= 0) return; // no changes
}
// Total to insert:
size = cnt * ilen;
if (action != A_CHANGE) {
// Always expand series for INSERT and APPEND actions:
Expand_Series(series, index, size);
} else {
if (size > rlen)
Expand_Series(series, index, size-rlen);
else if (size < rlen && DS_REF(AN_PART))
Remove_Series(series, index, rlen-size);
else if (size + index > tail) {
EXPAND_SERIES_TAIL(series, size - (tail - index));
}
}
// For dup count:
for (; cnt > 0; cnt--) {
Insert_String(series, index, arg_ser, VAL_INDEX(arg), ilen, TRUE);
index += ilen;
}
TERM_SERIES(series);
VAL_INDEX(string) = (action == A_APPEND) ? 0 : index;
}
*/ static REBCNT Do_Eval_Rule(REBPARSE *parse, REBCNT index, REBVAL **rule)
/*
** Evaluate the input as a code block. Advance input if
** rule succeeds. Return new index or failure.
**
** Examples:
** do skip
** do end
** do "abc"
** do 'abc
** do [...]
** do variable
** do datatype!
** do quote 123
** do into [...]
**
** Problem: cannot write: set var do datatype!
**
***********************************************************************/
{
REBVAL value;
REBVAL *item = *rule;
REBCNT n;
REBPARSE newparse;
// First, check for end of input:
if (index >= parse->series->tail) {
if (IS_WORD(item) && VAL_CMD(item) == SYM_END) return index;
else return NOT_FOUND;
}
// Evaluate next N input values:
index = Do_Next(parse->series, index, FALSE);
// Value is on top of stack (volatile!):
value = *DS_POP;
if (THROWN(&value)) Throw_Break(&value);
// Get variable or command:
if (IS_WORD(item)) {
n = VAL_CMD(item);
if (n == SYM_SKIP)
return (IS_SET(&value)) ? index : NOT_FOUND;
if (n == SYM_QUOTE) {
item = item + 1;
(*rule)++;
if (IS_END(item)) Trap1(RE_PARSE_END, item-2);
if (IS_PAREN(item)) {
item = Do_Block_Value_Throw(item); // might GC
}
}
else if (n == SYM_INTO) {
item = item + 1;
(*rule)++;
if (IS_END(item)) Trap1(RE_PARSE_END, item-2);
item = Get_Parse_Value(item); // sub-rules
if (!IS_BLOCK(item)) Trap1(RE_PARSE_RULE, item-2);
if (!ANY_BINSTR(&value) && !ANY_BLOCK(&value)) return NOT_FOUND;
return (Parse_Series(&value, VAL_BLK_DATA(item), parse->flags, 0) == VAL_TAIL(&value))
? index : NOT_FOUND;
}
else if (n > 0)
Trap1(RE_PARSE_RULE, item);
else
item = Get_Parse_Value(item); // variable
}
else if (IS_PATH(item)) {
item = Get_Parse_Value(item); // variable
}
else if (IS_SET_WORD(item) || IS_GET_WORD(item) || IS_SET_PATH(item) || IS_GET_PATH(item))
Trap1(RE_PARSE_RULE, item);
if (IS_NONE(item)) {
return (VAL_TYPE(&value) > REB_NONE) ? NOT_FOUND : index;
}
// Copy the value into its own block:
newparse.series = Make_Block(1);
SAVE_SERIES(newparse.series);
Append_Val(newparse.series, &value);
newparse.type = REB_BLOCK;
newparse.flags = parse->flags;
newparse.result = 0;
n = (Parse_Next_Block(&newparse, 0, item, 0) != NOT_FOUND) ? index : NOT_FOUND;
UNSAVE_SERIES(newparse.series);
return n;
}
*/ static REBCNT Parse_Rules_Loop(REBPARSE *parse, REBCNT index, REBVAL *rules, REBCNT depth)
/*
***********************************************************************/
{
REBSER *series = parse->series;
REBVAL *item; // current rule item
REBVAL *word; // active word to be set
REBCNT start; // recovery restart point
REBCNT i; // temp index point
REBCNT begin; // point at beginning of match
REBINT count; // iterated pattern counter
REBINT mincount; // min pattern count
REBINT maxcount; // max pattern count
REBVAL *item_hold;
REBVAL *val; // spare
REBCNT rulen;
REBSER *ser;
REBFLG flags;
REBCNT cmd;
REBVAL *rule_head = rules;
CHECK_STACK(&flags);
//if (depth > MAX_PARSE_DEPTH) Trap_Word(RE_LIMIT_HIT, SYM_PARSE, 0);
flags = 0;
word = 0;
mincount = maxcount = 1;
start = begin = index;
// For each rule in the rule block:
while (NOT_END(rules)) {
//Print_Parse_Index(parse->type, rules, series, index);
if (--Eval_Count <= 0 || Eval_Signals) Do_Signals();
//--------------------------------------------------------------------
// Pre-Rule Processing Section
//
// For non-iterated rules, including setup for iterated rules.
// The input index is not advanced here, but may be changed by
// a GET-WORD variable.
//--------------------------------------------------------------------
item = rules++;
// If word, set-word, or get-word, process it:
if (VAL_TYPE(item) >= REB_WORD && VAL_TYPE(item) <= REB_GET_WORD) {
// Is it a command word?
if (cmd = VAL_CMD(item)) {
if (!IS_WORD(item)) Trap1(RE_PARSE_COMMAND, item); // SET or GET not allowed
if (cmd <= SYM_BREAK) { // optimization
switch (cmd) {
case SYM_OR_BAR:
return index; // reached it successfully
// Note: mincount = maxcount = 1 on entry
case SYM_WHILE:
SET_FLAG(flags, PF_WHILE);
case SYM_ANY:
mincount = 0;
case SYM_SOME:
maxcount = MAX_I32;
continue;
case SYM_OPT:
mincount = 0;
continue;
case SYM_COPY:
SET_FLAG(flags, PF_COPY);
case SYM_SET:
SET_FLAG(flags, PF_SET);
item = rules++;
if (!IS_WORD(item)) Trap1(RE_PARSE_VARIABLE, item);
if (VAL_CMD(item)) Trap1(RE_PARSE_COMMAND, item);
word = item;
continue;
case SYM_NOT:
SET_FLAG(flags, PF_NOT);
flags ^= (1<<PF_NOT2);
continue;
case SYM_AND:
SET_FLAG(flags, PF_AND);
continue;
case SYM_THEN:
SET_FLAG(flags, PF_THEN);
continue;
case SYM_REMOVE:
SET_FLAG(flags, PF_REMOVE);
continue;
case SYM_INSERT:
SET_FLAG(flags, PF_INSERT);
goto post;
case SYM_CHANGE:
SET_FLAG(flags, PF_CHANGE);
continue;
case SYM_RETURN:
if (IS_PAREN(rules)) {
item = Do_Block_Value_Throw(rules); // might GC
Throw_Return_Value(item);
}
SET_FLAG(flags, PF_RETURN);
continue;
case SYM_ACCEPT:
case SYM_BREAK:
parse->result = 1;
return index;
case SYM_REJECT:
parse->result = -1;
return index;
case SYM_FAIL:
index = NOT_FOUND;
goto post;
case SYM_IF:
item = rules++;
if (IS_END(item)) goto bad_end;
if (!IS_PAREN(item)) Trap1(RE_PARSE_RULE, item);
item = Do_Block_Value_Throw(item); // might GC
if (IS_TRUE(item)) continue;
else {
index = NOT_FOUND;
goto post;
}
case SYM_LIMIT:
Trap0(RE_NOT_DONE);
//val = Get_Parse_Value(rules++);
// if (IS_INTEGER(val)) limit = index + Int32(val);
// else if (ANY_SERIES(val)) limit = VAL_INDEX(val);
// else goto
//goto bad_rule;
// goto post;
case SYM_QQ:
Print_Parse_Index(parse->type, rules, series, index);
continue;
}
}
// Any other cmd must be a match command, so proceed...
} else { // It's not a PARSE command, get or set it:
// word: - set a variable to the series at current index
if (IS_SET_WORD(item)) {
Set_Var_Series(item, parse->type, series, index);
continue;
}
// :word - change the index for the series to a new position
if (IS_GET_WORD(item)) {
item = Get_Var(item);
// CureCode #1263 change
//if (parse->type != VAL_TYPE(item) || VAL_SERIES(item) != series)
// Trap1(RE_PARSE_SERIES, rules-1);
if (!ANY_SERIES(item)) Trap1(RE_PARSE_SERIES, rules-1);
index = Set_Parse_Series(parse, item);
series = parse->series;
continue;
}
// word - some other variable
if (IS_WORD(item)) {
item = Get_Var(item);
}
// item can still be 'word or /word
}
}
else if (ANY_PATH(item)) {
item = Do_Parse_Path(item, parse, &index); // index can be modified
if (index > series->tail) index = series->tail;
if (item == 0) continue; // for SET and GET cases
}
if (IS_PAREN(item)) {
Do_Block_Value_Throw(item); // might GC
if (index > series->tail) index = series->tail;
continue;
}
// Counter? 123
if (IS_INTEGER(item)) { // Specify count or range count
SET_FLAG(flags, PF_WHILE);
mincount = maxcount = Int32s(item, 0);
item = Get_Parse_Value(rules++);
if (IS_END(item)) Trap1(RE_PARSE_END, rules-2);
if (IS_INTEGER(item)) {
maxcount = Int32s(item, 0);
item = Get_Parse_Value(rules++);
if (IS_END(item)) Trap1(RE_PARSE_END, rules-2);
}
}
// else fall through on other values and words
//--------------------------------------------------------------------
// Iterated Rule Matching Section:
//
// Repeats the same rule N times or until the rule fails.
// The index is advanced and stored in a temp variable i until
// the entire rule has been satisfied.
//--------------------------------------------------------------------
item_hold = item; // a command or literal match value
if (VAL_TYPE(item) <= REB_UNSET || VAL_TYPE(item) >= REB_NATIVE) goto bad_rule;
begin = index; // input at beginning of match section
rulen = 0; // rules consumed (do not use rule++ below)
i = index;
//note: rules var already advanced
for (count = 0; count < maxcount;) {
item = item_hold;
if (IS_WORD(item)) {
switch (cmd = VAL_WORD_CANON(item)) {
case SYM_SKIP:
i = (index < series->tail) ? index+1 : NOT_FOUND;
break;
case SYM_END:
i = (index < series->tail) ? NOT_FOUND : series->tail;
break;
case SYM_TO:
case SYM_THRU:
if (IS_END(rules)) goto bad_end;
item = Get_Parse_Value(rules);
rulen = 1;
i = Parse_To(parse, index, item, cmd == SYM_THRU);
break;
case SYM_QUOTE:
if (IS_END(rules)) goto bad_end;
rulen = 1;
if (IS_PAREN(rules)) {
item = Do_Block_Value_Throw(rules); // might GC
}
else item = rules;
i = (0 == Cmp_Value(BLK_SKIP(series, index), item, parse->flags & AM_FIND_CASE)) ? index+1 : NOT_FOUND;
break;
case SYM_INTO:
if (IS_END(rules)) goto bad_end;
rulen = 1;
item = Get_Parse_Value(rules); // sub-rules
if (!IS_BLOCK(item)) goto bad_rule;
val = BLK_SKIP(series, index);
i = (
(ANY_BINSTR(val) || ANY_BLOCK(val))
&& (Parse_Series(val, VAL_BLK_DATA(item), parse->flags, depth+1) == VAL_TAIL(val))
) ? index+1 : NOT_FOUND;
break;
case SYM_DO:
if (!IS_BLOCK_INPUT(parse)) goto bad_rule;
i = Do_Eval_Rule(parse, index, &rules);
rulen = 1;
break;
default:
goto bad_rule;
}
}
else if (IS_BLOCK(item)) {
item = VAL_BLK_DATA(item);
//if (IS_END(rules) && item == rule_head) {
// rules = item;
// goto top;
//}
i = Parse_Rules_Loop(parse, index, item, depth+1);
if (parse->result) {
index = (parse->result > 0) ? i : NOT_FOUND;
parse->result = 0;
break;
}
}
// Parse according to datatype:
else {
if (IS_BLOCK_INPUT(parse))
i = Parse_Next_Block(parse, index, item, depth+1);
else
i = Parse_Next_String(parse, index, item, depth+1);
}
// Necessary for special cases like: some [to end]
// i: indicates new index or failure of the match, but
// that does not mean failure of the rule, because optional
// matches can still succeed, if if the last match failed.
if (i != NOT_FOUND) {
count++; // may overflow to negative
if (count < 0) count = MAX_I32; // the forever case
// If input did not advance:
if (i == index && !GET_FLAG(flags, PF_WHILE)) {
if (count < mincount) index = NOT_FOUND; // was not enough
break;
}
}
//if (i >= series->tail) { // OLD check: no more input
else {
if (count < mincount) index = NOT_FOUND; // was not enough
else if (i != NOT_FOUND) index = i;
// else keep index as is.
break;
}
index = i;
// A BREAK word stopped us:
//if (parse->result) {parse->result = 0; break;}
}
rules += rulen;
//if (index > series->tail && index != NOT_FOUND) index = series->tail;
if (index > series->tail) index = NOT_FOUND;
//--------------------------------------------------------------------
// Post Match Processing:
//--------------------------------------------------------------------
post:
// Process special flags:
if (flags) {
// NOT before all others:
if (GET_FLAG(flags, PF_NOT)) {
if (GET_FLAG(flags, PF_NOT2) && index != NOT_FOUND) index = NOT_FOUND;
else index = begin;
}
if (index == NOT_FOUND) { // Failure actions:
// not decided: if (word) Set_Var_Basic(word, REB_NONE);
if (GET_FLAG(flags, PF_THEN)) {
SKIP_TO_BAR(rules);
if (!IS_END(rules)) rules++;
}
}
else { // Success actions:
count = (begin > index) ? 0 : index - begin; // how much we advanced the input
if (GET_FLAG(flags, PF_COPY)) {
ser = (IS_BLOCK_INPUT(parse))
? Copy_Block_Len(series, begin, count)
: Copy_String(series, begin, count); // condenses
Set_Var_Series(word, parse->type, ser, 0);
}
else if (GET_FLAG(flags, PF_SET)) {
if (IS_BLOCK_INPUT(parse)) {
item = Get_Var_Safe(word);
if (count == 0) SET_NONE(item);
else *item = *BLK_SKIP(series, begin);
}
else {
item = Get_Var_Safe(word);
if (count == 0) SET_NONE(item);
else {
i = GET_ANY_CHAR(series, begin);
if (parse->type == REB_BINARY) {
SET_INTEGER(item, i);
} else {
SET_CHAR(item, i);
}
}
}
}
if (GET_FLAG(flags, PF_RETURN)) {
ser = (IS_BLOCK_INPUT(parse))
? Copy_Block_Len(series, begin, count)
: Copy_String(series, begin, count); // condenses
Throw_Return_Series(parse->type, ser);
}
if (GET_FLAG(flags, PF_REMOVE)) {
if (count) Remove_Series(series, begin, count);
index = begin;
}
if (flags & (1<<PF_INSERT | 1<<PF_CHANGE)) {
count = GET_FLAG(flags, PF_INSERT) ? 0 : count;
cmd = GET_FLAG(flags, PF_INSERT) ? 0 : (1<<AN_PART);
item = rules++;
if (IS_END(item)) goto bad_end;
// Check for ONLY flag:
if (IS_WORD(item) && NZ(cmd = VAL_CMD(item))) {
if (cmd != SYM_ONLY) goto bad_rule;
cmd |= (1<<AN_ONLY);
item = rules++;
}
// CHECK FOR QUOTE!!
item = Get_Parse_Value(item); // new value
if (IS_UNSET(item)) Trap1(RE_NO_VALUE, rules-1);
if (IS_END(item)) goto bad_end;
if (IS_BLOCK_INPUT(parse)) {
index = Modify_Block(GET_FLAG(flags, PF_CHANGE) ? A_CHANGE : A_INSERT,
series, begin, item, cmd, count, 1);
if (IS_LIT_WORD(item)) SET_TYPE(BLK_SKIP(series, index-1), REB_WORD);
}
else {
if (parse->type == REB_BINARY) cmd |= (1<<AN_SERIES); // special flag
index = Modify_String(GET_FLAG(flags, PF_CHANGE) ? A_CHANGE : A_INSERT,
series, begin, item, cmd, count, 1);
}
}
if (GET_FLAG(flags, PF_AND)) index = begin;
}
flags = 0;
word = 0;
}
// Goto alternate rule and reset input:
if (index == NOT_FOUND) {
SKIP_TO_BAR(rules);
if (IS_END(rules)) break;
rules++;
index = begin = start;
}
begin = index;
mincount = maxcount = 1;
}
return index;
bad_rule:
Trap1(RE_PARSE_RULE, rules-1);
bad_end:
Trap1(RE_PARSE_END, rules-1);
return 0;
}
*/ REBYTE *Security_Policy(REBCNT sym, REBVAL *name)
/*
** Given a security symbol (like FILE) and a value (like the file
** path) returns the security policy (RWX) allowed for it.
**
** Args:
**
** sym: word that represents the type ['file 'net]
** name: file or path value
**
** Returns BTYE array of flags for the policy class:
**
** flags: [rrrr wwww xxxx ----]
**
** Where each byte is:
** 0: SEC_ALLOW
** 1: SEC_ASK
** 2: SEC_THROW
** 3: SEC_QUIT
**
** The secuity is defined by the system/state/policies object, that
** is of the form:
**
** [
** file: [%file1 tuple-flags %file2 ... default tuple-flags]
** net: [...]
** call: tuple-flags
** stack: tuple-flags
** eval: integer (limit)
** ]
**
***********************************************************************/
{
REBVAL *policy = Get_System(SYS_STATE, STATE_POLICIES);
REBYTE *flags;
REBCNT len;
REBCNT errcode = RE_SECURITY_ERROR;
if (!IS_OBJECT(policy)) goto error;
// Find the security class in the block: (file net call...)
policy = Find_Word_Value(VAL_OBJ_FRAME(policy), sym);
if (!policy) goto error;
// Obtain the policies for it:
// Check for a master tuple: [file rrrr.wwww.xxxx]
if (IS_TUPLE(policy)) return VAL_TUPLE(policy); // non-aligned
// removed A90: if (IS_INTEGER(policy)) return (REBYTE*)VAL_INT64(policy); // probably not used
// Only other form is detailed block:
if (!IS_BLOCK(policy)) goto error;
// Scan block of policies for the class: [file [allow read quit write]]
len = 0; // file or url length
flags = 0; // policy flags
for (policy = VAL_BLK(policy); NOT_END(policy); policy += 2) {
// Must be a policy tuple:
if (!IS_TUPLE(policy+1)) goto error;
// Is it a policy word:
if (IS_WORD(policy)) { // any word works here
// If no strings found, use the default:
if (len == 0) flags = VAL_TUPLE(policy+1); // non-aligned
}
// Is it a string (file or URL):
else if (ANY_BINSTR(policy) && name) {
//Debug_Fmt("sec: %r %r", policy, name);
if (Match_Sub_Path(VAL_SERIES(policy), VAL_SERIES(name))) {
// Is the match adequate?
if (VAL_TAIL(name) >= len) {
len = VAL_TAIL(name);
flags = VAL_TUPLE(policy+1); // non-aligned
}
}
}
else goto error;
}
if (!flags) {
errcode = RE_SECURITY;
policy = name ? name : 0;
error:
if (!policy) {
Init_Word(DS_TOP, sym);
policy = DS_TOP;
}
Trap1(errcode, policy);
}
return flags;
}
*/ REBINT Find_Key(REBSER *series, REBSER *hser, REBVAL *key, REBINT wide, REBCNT cased, REBYTE mode)
/*
** Returns hash index (either the match or the new one).
** A return of zero is valid (as a hash index);
**
** Wide: width of record (normally 2, a key and a value).
**
** Modes:
** 0 - search, return hash if found or not
** 1 - search, return hash, else return -1 if not
** 2 - search, return hash, else append value and return -1
**
***********************************************************************/
{
REBCNT *hashes;
REBCNT skip;
REBCNT hash;
REBCNT len;
REBCNT n;
REBVAL *val;
// Compute hash for value:
len = hser->tail;
hash = Hash_Value(key, len);
if (!hash) Trap_Type_DEAD_END(key);
// Determine skip and first index:
skip = (len == 0) ? 0 : (hash & 0x0000FFFF) % len;
if (skip == 0) skip = 1;
hash = (len == 0) ? 0 : (hash & 0x00FFFF00) % len;
// Scan hash table for match:
hashes = (REBCNT*)hser->data;
if (ANY_WORD(key)) {
while ((n = hashes[hash])) {
val = BLK_SKIP(series, (n-1) * wide);
if (
ANY_WORD(val) &&
(VAL_WORD_SYM(key) == VAL_BIND_SYM(val) ||
(!cased && VAL_WORD_CANON(key) == VAL_BIND_CANON(val)))
) return hash;
hash += skip;
if (hash >= len) hash -= len;
}
}
else if (ANY_BINSTR(key)) {
while ((n = hashes[hash])) {
val = BLK_SKIP(series, (n-1) * wide);
if (
VAL_TYPE(val) == VAL_TYPE(key)
&& 0 == Compare_String_Vals(key, val, (REBOOL)(!IS_BINARY(key) && !cased))
) return hash;
hash += skip;
if (hash >= len) hash -= len;
}
} else {
while ((n = hashes[hash])) {
val = BLK_SKIP(series, (n-1) * wide);
if (VAL_TYPE(val) == VAL_TYPE(key) && 0 == Cmp_Value(key, val, !cased)) return hash;
hash += skip;
if (hash >= len) hash -= len;
}
}
// Append new value the target series:
if (mode > 1) {
hashes[hash] = SERIES_TAIL(series)+1;
//Debug_Num("hash:", hashes[hash]);
Append_Series(series, (REBYTE*)key, wide);
//Dump_Series(series, "hash");
}
return (mode > 0) ? NOT_FOUND : hash;
}
*/ REBCNT Modify_String(REBCNT action, REBSER *dst_ser, REBCNT dst_idx, const REBVAL *src_val, REBCNT flags, REBINT dst_len, REBINT dups)
/*
** action: INSERT, APPEND, CHANGE
**
** dst_ser: target
** dst_idx: position
** src_val: source
** flags: AN_PART
** dst_len: length to remove
** dups: dup count
**
** return: new dst_idx
**
***********************************************************************/
{
REBSER *src_ser = 0;
REBCNT src_idx = 0;
REBCNT src_len;
REBCNT tail = SERIES_TAIL(dst_ser);
REBINT size; // total to insert
if (dups < 0) return (action == A_APPEND) ? 0 : dst_idx;
if (action == A_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 = Append_Byte(0, Int8u(src_val)); // creates a binary
}
else if (IS_BLOCK(src_val)) {
src_ser = Join_Binary(src_val); // NOTE: it's the shared FORM buffer!
}
else if (IS_CHAR(src_val)) {
src_ser = Make_Binary(6); // (I hate unicode)
src_ser->tail = Encode_UTF8_Char(BIN_HEAD(src_ser), VAL_CHAR(src_val));
}
else if (!ANY_BINSTR(src_val)) Trap_Arg_DEAD_END(src_val);
}
else if (IS_CHAR(src_val)) {
src_ser = Append_Byte(0, VAL_CHAR(src_val)); // unicode ok too
}
else if (IS_BLOCK(src_val)) {
src_ser = Form_Tight_Block(src_val);
}
else if (!ANY_STR(src_val) || IS_TAG(src_val)) {
src_ser = Copy_Form_Value(src_val, 0);
}
// Use either new src or the one that was passed:
if (src_ser) {
src_len = SERIES_TAIL(src_ser);
}
else {
src_ser = VAL_SERIES(src_val);
src_idx = VAL_INDEX(src_val);
src_len = VAL_LEN(src_val);
}
// For INSERT or APPEND with /PART use the dst_len not src_len:
if (action != A_CHANGE && GET_FLAG(flags, AN_PART)) src_len = dst_len;
// 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) {
src_ser = Copy_Series_Part(src_ser, src_idx, src_len);
src_idx = 0;
}
// Total to insert:
size = dups * src_len;
if (action != A_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_SERIES(dst_ser);
return (action == A_APPEND) ? 0 : dst_idx;
}
/* parse struct attribute */
static void parse_attr (REBVAL *blk, REBINT *raw_size, REBUPT *raw_addr)
{
REBVAL *attr = VAL_BLK_DATA(blk);
*raw_size = -1;
*raw_addr = 0;
while (NOT_END(attr)) {
if (IS_SET_WORD(attr)) {
switch (VAL_WORD_CANON(attr)) {
case SYM_RAW_SIZE:
++ attr;
if (IS_INTEGER(attr)) {
if (*raw_size > 0) /* duplicate raw-size */
raise Error_Invalid_Arg(attr);
*raw_size = VAL_INT64(attr);
if (*raw_size <= 0)
raise Error_Invalid_Arg(attr);
}
else
raise Error_Invalid_Arg(attr);
break;
case SYM_RAW_MEMORY:
++ attr;
if (IS_INTEGER(attr)) {
if (*raw_addr != 0) /* duplicate raw-memory */
raise Error_Invalid_Arg(attr);
*raw_addr = VAL_UNT64(attr);
if (*raw_addr == 0)
raise Error_Invalid_Arg(attr);
}
else
raise Error_Invalid_Arg(attr);
break;
case SYM_EXTERN:
++ attr;
if (*raw_addr != 0) /* raw-memory is exclusive with extern */
raise Error_Invalid_Arg(attr);
if (!IS_BLOCK(attr)
|| VAL_LEN(attr) != 2) {
raise Error_Invalid_Arg(attr);
}
else {
REBVAL *lib;
REBVAL *sym;
CFUNC *addr;
lib = VAL_BLK_SKIP(attr, 0);
sym = VAL_BLK_SKIP(attr, 1);
if (!IS_LIBRARY(lib))
raise Error_Invalid_Arg(attr);
if (IS_CLOSED_LIB(VAL_LIB_HANDLE(lib)))
raise Error_0(RE_BAD_LIBRARY);
if (!ANY_BINSTR(sym))
raise Error_Invalid_Arg(sym);
addr = OS_FIND_FUNCTION(
LIB_FD(VAL_LIB_HANDLE(lib)), s_cast(VAL_DATA(sym))
);
if (!addr)
raise Error_1(RE_SYMBOL_NOT_FOUND, sym);
*raw_addr = cast(REBUPT, addr);
}
break;
/*
case SYM_ALIGNMENT:
++ attr;
if (IS_INTEGER(attr)) {
alignment = VAL_INT64(attr);
} else {
raise Error_Invalid_Arg(attr);
}
break;
*/
default:
raise Error_Invalid_Arg(attr);
}
}
else
raise Error_Invalid_Arg(attr);
++ attr;
}
}
static REBCNT find_string(
REBSER *series,
REBCNT index,
REBCNT end,
REBVAL *target,
REBCNT target_len,
REBCNT flags,
REBINT skip
) {
assert(end >= index);
if (target_len > end - index) // series not long enough to have target
return NOT_FOUND;
REBCNT start = index;
if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
skip = -1;
start = 0;
if (flags & AM_FIND_LAST) index = end - target_len;
else index--;
}
if (ANY_BINSTR(target)) {
// Do the optimal search or the general search?
if (
BYTE_SIZE(series)
&& VAL_BYTE_SIZE(target)
&& !(flags & ~(AM_FIND_CASE|AM_FIND_MATCH))
) {
return Find_Byte_Str(
series,
start,
VAL_BIN_AT(target),
target_len,
NOT(GET_FLAG(flags, ARG_FIND_CASE - 1)),
GET_FLAG(flags, ARG_FIND_MATCH - 1)
);
}
else {
return Find_Str_Str(
series,
start,
index,
end,
skip,
VAL_SERIES(target),
VAL_INDEX(target),
target_len,
flags & (AM_FIND_MATCH|AM_FIND_CASE)
);
}
}
else if (IS_BINARY(target)) {
const REBOOL uncase = FALSE;
return Find_Byte_Str(
series,
start,
VAL_BIN_AT(target),
target_len,
uncase, // "don't treat case insensitively"
GET_FLAG(flags, ARG_FIND_MATCH - 1)
);
}
else if (IS_CHAR(target)) {
return Find_Str_Char(
VAL_CHAR(target),
series,
start,
index,
end,
skip,
flags
);
}
else if (IS_INTEGER(target)) {
return Find_Str_Char(
cast(REBUNI, VAL_INT32(target)),
series,
start,
index,
end,
skip,
flags
);
}
else if (IS_BITSET(target)) {
return Find_Str_Bitset(
series,
start,
index,
end,
skip,
VAL_SERIES(target),
flags
);
}
return NOT_FOUND;
}