*/ void *Use_Port_State(REBSER *port, REBCNT device, REBCNT size)
/*
** Use private state area in a port. Create if necessary.
** The size is that of a binary structure used by
** the port for storing internal information.
**
***********************************************************************/
{
REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
// If state is not a binary structure, create it:
if (!IS_BINARY(state)) {
REBSER *data = Make_Binary(size);
REBREQ *req = (REBREQ*)STR_HEAD(data);
req->clen = size;
CLEAR(STR_HEAD(data), size);
//data->tail = size; // makes it easier for ACCEPT to clone the port
SET_FLAG(req->flags, RRF_ALLOC); // not on stack
req->port = port;
req->device = device;
Val_Init_Binary(state, data);
}
return (void *)VAL_BIN(state);
}
*/ RL_API int RL_Do_Binary(REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *result)
/*
** Evaluate an encoded binary script such as compressed text.
**
** Returns:
** The datatype of the result or zero if error in the encoding.
** Arguments:
** bin - by default, a REBOL compressed UTF-8 (or ASCII) script.
** length - the length of the data.
** flags - special flags (set to zero at this time).
** key - encoding, encryption, or signature key.
** result - value returned from evaluation.
** Notes:
** As of A104, only compressed scripts are supported, however,
** rebin, cloaked, signed, and encrypted formats will be supported.
**
***********************************************************************/
{
REBSER spec = {0};
REBSER *text;
REBVAL *val;
#ifdef DUMP_INIT_SCRIPT
int f;
#endif
//Cloak(TRUE, code, NAT_SPEC_SIZE, &key[0], 20, TRUE);
spec.data = bin;
spec.tail = length;
text = Decompress(&spec, 0, -1, 10000000, 0);
if (!text) return FALSE;
Append_Byte(text, 0);
#ifdef DUMP_INIT_SCRIPT
f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE );
_write(f, STR_HEAD(text), LEN_BYTES(STR_HEAD(text)));
_close(f);
#endif
SAVE_SERIES(text);
val = Do_String(text->data, flags);
UNSAVE_SERIES(text);
if (IS_ERROR(val)) // && (VAL_ERR_NUM(val) != RE_QUIT)) {
Print_Value(val, 1000, FALSE);
if (result) {
*result = Value_To_RXI(val);
return Reb_To_RXT[VAL_TYPE(val)];
}
return 0;
}
STOID Sniff_String(REBSER *ser, REBCNT idx, REB_STRF *sf)
{
// Scan to find out what special chars the string contains?
REBYTE *bp = STR_HEAD(ser);
REBUNI *up = (REBUNI*)bp;
REBUNI c;
REBCNT n;
for (n = idx; n < SERIES_TAIL(ser); n++) {
c = (BYTE_SIZE(ser)) ? (REBUNI)(bp[n]) : up[n];
switch (c) {
case '{':
sf->brace_in++;
break;
case '}':
sf->brace_out++;
if (sf->brace_out > sf->brace_in) sf->malign++;
break;
case '"':
sf->quote++;
break;
case '\n':
sf->newline++;
break;
default:
if (c == 0x1e) sf->chr1e += 4; // special case of ^(1e)
else if (IS_CHR_ESC(c)) sf->escape++;
else if (c >= 0x1000) sf->paren += 6; // ^(1234)
else if (c >= 0x100) sf->paren += 5; // ^(123)
else if (c >= 0x80) sf->paren += 4; // ^(12)
}
}
if (sf->brace_in != sf->brace_out) sf->malign++;
}
//
// Dump_Stack: C
//
// Prints stack counting levels from the passed in number. Pass 0 to start.
//
void Dump_Stack(REBFRM *f, REBCNT level)
{
REBINT n;
REBVAL *arg;
REBVAL *param;
Debug_Fmt(""); // newline.
if (f == NULL) f = FS_TOP;
if (f == NULL) {
Debug_Fmt("*STACK[] - NO FRAMES*");
return;
}
Debug_Fmt(
"STACK[%d](%s) - %d",
level,
STR_HEAD(FRM_LABEL(f)),
f->eval_type // note: this is now an ordinary Reb_Kind, stringify it
);
if (NOT(Is_Any_Function_Frame(f))) {
Debug_Fmt("(no function call pending or in progress)");
return;
}
n = 1;
arg = FRM_ARG(f, 1);
param = FUNC_PARAMS_HEAD(f->func);
for (; NOT_END(param); ++param, ++arg, ++n) {
Debug_Fmt(
" %s: %72r",
STR_HEAD(VAL_PARAM_SPELLING(param)),
arg
);
}
if (f->prior)
Dump_Stack(f->prior, level + 1);
}
*/ RL_API int RL_Do_Binary(int *exit_status, const REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *result)
/*
** Evaluate an encoded binary script such as compressed text.
**
** Returns:
** The datatype of the result or zero if error in the encoding.
** Arguments:
** bin - by default, a REBOL compressed UTF-8 (or ASCII) script.
** length - the length of the data.
** flags - special flags (set to zero at this time).
** key - encoding, encryption, or signature key.
** result - value returned from evaluation.
** Notes:
** As of A104, only compressed scripts are supported, however,
** rebin, cloaked, signed, and encrypted formats will be supported.
**
***********************************************************************/
{
REBSER *text;
#ifdef DUMP_INIT_SCRIPT
int f;
#endif
int do_result;
text = Decompress(bin, length, -1, FALSE, FALSE);
if (!text) return FALSE;
Append_Codepoint_Raw(text, 0);
#ifdef DUMP_INIT_SCRIPT
f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE );
_write(f, STR_HEAD(text), LEN_BYTES(STR_HEAD(text)));
_close(f);
#endif
PUSH_GUARD_SERIES(text);
do_result = RL_Do_String(exit_status, text->data, flags, result);
DROP_GUARD_SERIES(text);
Free_Series(text);
return do_result;
}
*/ static REBSER *Decode_Base16(const REBYTE **src, REBCNT len, REBYTE delim)
/*
***********************************************************************/
{
REBYTE *bp;
const REBYTE *cp;
REBCNT count = 0;
REBINT accum = 0;
REBYTE lex;
REBINT val;
REBSER *ser;
ser = Make_Binary(len / 2);
bp = STR_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++ = (REBYTE)accum;
}
else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
}
if (count & 1) goto err; // improper modulus
*bp = 0;
ser->tail = bp - STR_HEAD(ser);
return ser;
err:
Free_Series(ser);
*src = cp;
return 0;
}
xx*/ void Print_Dump_Value(REBVAL *value, REBYTE *label)
/*
** Dump a value's contents for debugging purposes.
**
***********************************************************************/
{
REBSER *series;
series = Copy_Bytes(label, -1);
SAVE_SERIES(series);
series = Dump_Value(value, series);
Debug_Str(STR_HEAD(series));
UNSAVE_SERIES(series);
}
*/ static REBSER *Decode_Base2(const REBYTE **src, REBCNT len, REBYTE delim)
/*
***********************************************************************/
{
REBYTE *bp;
const REBYTE *cp;
REBCNT count = 0;
REBINT 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++ = (REBYTE)accum;
count = 0;
accum = 0;
}
}
else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
}
if (count) goto err; // improper modulus
*bp = 0;
ser->tail = bp - STR_HEAD(ser);
return ser;
err:
Free_Series(ser);
*src = cp;
return 0;
}
*/ static REBSER *Decode_Base64(const REBYTE **src, REBCNT len, REBYTE delim)
/*
***********************************************************************/
{
REBYTE *bp;
const REBYTE *cp;
REBCNT flip = 0;
REBINT accum = 0;
REBYTE lex;
REBSER *ser;
// Allocate buffer large enough to hold result:
// Accounts for e bytes decoding into 3 bytes.
ser = Make_Binary(((len + 3) * 3) / 4);
bp = STR_HEAD(ser);
cp = *src;
for (; len > 0; cp++, len--) {
// Check for terminating delimiter (optional):
if (delim && *cp == delim) break;
// Check for char out of range:
if (*cp > 127) {
if (*cp == 0xA0) continue; // hard space
goto err;
}
lex = Debase64[*cp];
if (lex < BIN_SPACE) {
if (*cp != '=') {
accum = (accum << 6) + lex;
if (flip++ == 3) {
*bp++ = (REBYTE)(accum >> 16);
*bp++ = (REBYTE)(accum >> 8);
*bp++ = (REBYTE)(accum);
accum = 0;
flip = 0;
}
} else {
*/ REBSER *Prep_String(REBSER *series, REBYTE **str, REBCNT len)
/*
** Helper function for the string related Mold functions below.
** Creates or expands the series and provides the location to
** copy text into.
**
***********************************************************************/
{
REBCNT tail;
if (!series) {
series = Make_Binary(len);
series->tail = len;
*str = STR_HEAD(series);
}
else {
tail = SERIES_TAIL(series);
EXPAND_SERIES_TAIL(series, len);
*str = STR_SKIP(series, tail);
}
return series;
}
//
// Dump_Values: C
//
// Print values in raw hex; If memory is corrupted this still needs to work.
//
void Dump_Values(RELVAL *vp, REBCNT count)
{
REBYTE buf[2048];
REBYTE *cp;
REBCNT l, n;
REBCNT *bp = (REBCNT*)vp;
const REBYTE *type;
cp = buf;
for (l = 0; l < count; l++) {
REBVAL *val = cast(REBVAL*, bp);
cp = Form_Hex_Pad(cp, l, 8);
*cp++ = ':';
*cp++ = ' ';
type = Get_Type_Name((REBVAL*)bp);
for (n = 0; n < 11; n++) {
if (*type) *cp++ = *type++;
else *cp++ = ' ';
}
*cp++ = ' ';
for (n = 0; n < sizeof(REBVAL) / sizeof(REBCNT); n++) {
cp = Form_Hex_Pad(cp, *bp++, 8);
*cp++ = ' ';
}
n = 0;
if (IS_WORD(val) || IS_GET_WORD(val) || IS_SET_WORD(val)) {
const REBYTE *name = STR_HEAD(VAL_WORD_SPELLING(val));
n = snprintf(
s_cast(cp), sizeof(buf) - (cp - buf), " (%s)", cs_cast(name)
);
}
*(cp + n) = 0;
Debug_Str(s_cast(buf));
cp = buf;
}
}
xx*/ void Dump_Block(REBVAL *blk, REBINT len)
/*
** Dump a block's contents for debugging purposes.
**
***********************************************************************/
{
REBSER *series;
//REBVAL *blk = BLK_HEAD(block);
//Print("BLOCK: %x Tail: %d Size: %d", block, block->tail, block->rest);
// change to a make string!!! no need to append to a series, this is a debug function
series = Make_Binary(100);
Append_Bytes(series, "[\n");
while (NOT_END(blk) && len-- > 0) {
Append_Byte(series, '\t');
Dump_Value(blk, series);
Append_Byte(series, '\n');
blk++;
}
Append_Byte(series, ']');
*STR_TAIL(series) = 0;
Debug_Str(STR_HEAD(series));
}
STOID Mold_String_Series(REBVAL *value, REB_MOLD *mold)
{
REBCNT len = VAL_LEN(value);
REBSER *ser = VAL_SERIES(value);
REBCNT idx = VAL_INDEX(value);
REB_STRF sf = {0};
REBYTE *bp;
REBUNI *up;
REBUNI *dp;
REBOOL uni = !BYTE_SIZE(ser);
REBCNT n;
REBUNI c;
// Empty string:
if (idx >= VAL_TAIL(value)) {
Append_Bytes(mold->series, "\"\""); //Trap0(RE_PAST_END);
return;
}
Sniff_String(ser, idx, &sf);
if (!GET_MOPT(mold, MOPT_ANSI_ONLY)) sf.paren = 0;
// Source can be 8 or 16 bits:
if (uni) up = UNI_HEAD(ser);
else bp = STR_HEAD(ser);
// If it is a short quoted string, emit it as "string":
if (len <= MAX_QUOTED_STR && sf.quote == 0 && sf.newline < 3) {
dp = Prep_Uni_Series(mold, len + sf.newline + sf.escape + sf.paren + sf.chr1e + 2);
*dp++ = '"';
for (n = idx; n < VAL_TAIL(value); n++) {
c = uni ? up[n] : (REBUNI)(bp[n]);
dp = Emit_Uni_Char(dp, c, (REBOOL)GET_MOPT(mold, MOPT_ANSI_ONLY)); // parened
}
*dp++ = '"';
*dp = 0;
return;
}
// It is a braced string, emit it as {string}:
if (!sf.malign) sf.brace_in = sf.brace_out = 0;
dp = Prep_Uni_Series(mold, len + sf.brace_in + sf.brace_out + sf.escape + sf.paren + sf.chr1e + 2);
*dp++ = '{';
for (n = idx; n < VAL_TAIL(value); n++) {
c = uni ? up[n] : (REBUNI)(bp[n]);
switch (c) {
case '{':
case '}':
if (sf.malign) {
*dp++ = '^';
*dp++ = c;
break;
}
case '\n':
case '"':
*dp++ = c;
break;
default:
dp = Emit_Uni_Char(dp, c, (REBOOL)GET_MOPT(mold, MOPT_ANSI_ONLY)); // parened
}
}
*dp++ = '}';
*dp = 0;
}
//
// MAKE_Tuple: C
//
REB_R MAKE_Tuple(
REBVAL *out,
enum Reb_Kind kind,
const REBVAL *opt_parent,
const REBVAL *arg
){
assert(kind == REB_TUPLE);
if (opt_parent)
fail (Error_Bad_Make_Parent(kind, opt_parent));
if (IS_TUPLE(arg))
return Move_Value(out, arg);
RESET_CELL(out, REB_TUPLE, CELL_MASK_NONE);
REBYTE *vp = VAL_TUPLE(out);
// !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or
// similar URL!s. In Rebol3 these captures come back the same type
// as the input instead of as STRING!, which was a latent bug in the
// network code of the 12-Dec-2012 release:
//
// https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110
//
// All attempts to convert a URL!-flavored IP address failed. Taking
// URL! here fixes it, though there are still open questions.
//
if (IS_TEXT(arg) or IS_URL(arg)) {
REBSIZ size;
const REBYTE *bp
= Analyze_String_For_Scan(&size, arg, MAX_SCAN_TUPLE);
if (Scan_Tuple(out, bp, size) == nullptr)
fail (arg);
return out;
}
if (ANY_ARRAY(arg)) {
REBCNT len = 0;
REBINT n;
RELVAL *item = VAL_ARRAY_AT(arg);
for (; NOT_END(item); ++item, ++vp, ++len) {
if (len >= MAX_TUPLE)
goto bad_make;
if (IS_INTEGER(item)) {
n = Int32(item);
}
else if (IS_CHAR(item)) {
n = VAL_CHAR(item);
}
else
goto bad_make;
if (n > 255 || n < 0)
goto bad_make;
*vp = n;
}
VAL_TUPLE_LEN(out) = len;
for (; len < MAX_TUPLE; len++) *vp++ = 0;
return out;
}
REBCNT alen;
if (IS_ISSUE(arg)) {
REBSTR *spelling = VAL_STRING(arg);
const REBYTE *ap = STR_HEAD(spelling);
size_t size = STR_SIZE(spelling); // UTF-8 len
if (size & 1)
fail (arg); // must have even # of chars
size /= 2;
if (size > MAX_TUPLE)
fail (arg); // valid even for UTF-8
VAL_TUPLE_LEN(out) = size;
for (alen = 0; alen < size; alen++) {
REBYTE decoded;
if ((ap = Scan_Hex2(&decoded, ap)) == NULL)
fail (arg);
*vp++ = decoded;
}
}
else if (IS_BINARY(arg)) {
REBYTE *ap = VAL_BIN_AT(arg);
REBCNT len = VAL_LEN_AT(arg);
if (len > MAX_TUPLE) len = MAX_TUPLE;
VAL_TUPLE_LEN(out) = len;
for (alen = 0; alen < len; alen++) *vp++ = *ap++;
}
else
fail (arg);
for (; alen < MAX_TUPLE; alen++) *vp++ = 0;
return out;
bad_make:
fail (Error_Bad_Make(REB_TUPLE, arg));
}
