*/ static void Read_File_Port(REBVAL *out, REBSER *port, REBREQ *file, REBVAL *path, REBCNT args, REBCNT len)
/*
** Read from a file port.
**
***********************************************************************/
{
REBSER *ser;
// Allocate read result buffer:
ser = Make_Binary(len);
Set_Series(REB_BINARY, out, ser); //??? what if already set?
// Do the read, check for errors:
file->common.data = BIN_HEAD(ser);
file->length = len;
if (OS_DO_DEVICE(file, RDC_READ) < 0)
Trap_Port(RE_READ_ERROR, port, file->error);
SERIES_TAIL(ser) = file->actual;
STR_TERM(ser);
// Convert to string or block of strings.
// NOTE: This code is incorrect for files read in chunks!!!
if (args & (AM_READ_STRING | AM_READ_LINES)) {
REBSER *nser = Decode_UTF_String(BIN_HEAD(ser), file->actual, -1);
if (nser == NULL) {
Trap(RE_BAD_DECODE);
}
Set_String(out, nser);
if (args & AM_READ_LINES) Set_Block(out, Split_Lines(out));
}
}
*/ void Init_Words(REBFLG only)
/*
** Only flags BIND_Table creation only (for threads).
**
***********************************************************************/
{
REBCNT n = Get_Hash_Prime(WORD_TABLE_SIZE * 4); // extra to reduce rehashing
if (!only) {
// Create the hash for locating words quickly:
// Note that the TAIL is never changed for this series.
PG_Word_Table.hashes = Make_Series(n+1, sizeof(REBCNT), FALSE);
KEEP_SERIES(PG_Word_Table.hashes, "word hashes"); // pointer array
Clear_Series(PG_Word_Table.hashes);
PG_Word_Table.hashes->tail = n;
// The word (symbol) table itself:
PG_Word_Table.series = Make_Block(WORD_TABLE_SIZE);
SET_NONE(BLK_HEAD(PG_Word_Table.series)); // Put a NONE at head.
KEEP_SERIES(PG_Word_Table.series, "word table"); // words are never GC'd
BARE_SERIES(PG_Word_Table.series); // don't bother to GC scan it
PG_Word_Table.series->tail = 1; // prevent the zero case
// A normal char array to hold symbol names:
PG_Word_Names = Make_Binary(6 * WORD_TABLE_SIZE); // average word size
KEEP_SERIES(PG_Word_Names, "word names");
}
// The bind table. Used to cache context indexes for given symbols.
Bind_Table = Make_Series(SERIES_REST(PG_Word_Table.series), 4, FALSE);
KEEP_SERIES(Bind_Table, "bind table"); // numeric table
CLEAR_SERIES(Bind_Table);
Bind_Table->tail = PG_Word_Table.series->tail;
}
*/ 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 void *RL_Make_String(u32 size, int unicode)
/*
** Allocate a new string or binary series.
**
** Returns:
** A pointer to a string or binary series.
** Arguments:
** size - the length of the string. The system will add one extra
** for a null terminator (not strictly required, but good for C.)
** unicode - set FALSE for ASCII/Latin1 strings, set TRUE for Unicode.
** Notes:
** Strings can be REBYTE or REBCHR sized (depends on R3 config.)
** Strings are allocated with REBOL's internal memory manager.
** Internal structures may change, so NO assumptions should be made!
** Strings are automatically garbage collected if there are
** no references to them from REBOL code (C code does nothing.)
** However, you can lock strings to prevent deallocation. (?? default)
**
***********************************************************************/
{
REBSER *result = unicode ? Make_Unicode(size) : Make_Binary(size);
// !!! Assume client does not have Free_Series() or MANAGE_SERIES()
// APIs, so the series we give back must be managed. But how can
// we be sure they get what usage they needed before the GC happens?
MANAGE_SERIES(result);
return result;
}
*/ REBSER *Decompress(REBSER *input, REBCNT index, REBINT len, REBCNT limit, REBFLG use_crc)
/*
** Decompress a binary (only).
**
***********************************************************************/
{
REBCNT size;
REBSER *output;
REBINT err;
if (len < 0 || (index + len > BIN_LEN(input))) len = BIN_LEN(input) - index;
// Get the size from the end and make the output buffer that size.
if (len <= 4) Trap0(RE_PAST_END); // !!! better msg needed
size = Bytes_To_Long(BIN_SKIP(input, len) - 4);
if (limit && size > limit) Trap_Num(RE_SIZE_LIMIT, size);
output = Make_Binary(size + 20); // (Why 20 extra? -CS)
//DISABLE_GC;
err = Z_uncompress(BIN_HEAD(output), (uLongf*)&size, BIN_HEAD(input) + index, len, use_crc);
if (err) {
if (PG_Boot_Phase < 2) return 0;
if (err == Z_MEM_ERROR) Trap0(RE_NO_MEMORY);
SET_INTEGER(DS_RETURN, err);
Trap1(RE_BAD_PRESS, DS_RETURN); //!!!provide error string descriptions
}
SET_STR_END(output, size);
SERIES_TAIL(output) = size;
//ENABLE_GC;
return output;
}
// Used for file loading during very early development.
static REBSER *Read_All_File(char *fname)
{
REBREQ file;
REBSER *ser = 0;
CLEAR(&file, sizeof(file));
file.clen = sizeof(file);
file.device = RDI_FILE;
file.file.path = fname;
SET_FLAG(file.modes, RFM_READ);
OS_DO_DEVICE(&file, RDC_OPEN);
if (file.error) return 0;
ser = Make_Binary((REBCNT)(file.file.size));
file.data = BIN_DATA(ser);
file.length = (REBCNT)(file.file.size);
OS_DO_DEVICE(&file, RDC_READ);
if (file.error) {
ser = 0;
}
else {
ser->tail = file.actual;
STR_TERM(ser);
}
OS_DO_DEVICE(&file, RDC_CLOSE);
return ser;
}
*/ REBSER *Copy_Wide_Str(void *src, REBINT len)
/*
** Create a REBOL string series from a wide char string.
** Minimize to bytes if possible
*/
{
REBSER *dst;
REBUNI *str = (REBUNI*)src;
if (Is_Wide(str, len)) {
REBUNI *up;
dst = Make_Unicode(len);
SERIES_TAIL(dst) = len;
up = UNI_HEAD(dst);
while (len-- > 0) *up++ = *str++;
*up = 0;
}
else {
REBYTE *bp;
dst = Make_Binary(len);
SERIES_TAIL(dst) = len;
bp = BIN_HEAD(dst);
while (len-- > 0) *bp++ = (REBYTE)*str++;
*bp = 0;
}
return dst;
}
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;
}
//
// 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));
}
//
// RL_Make_String: C
//
// Allocate a new string or binary series.
//
// Returns:
// A pointer to a string or binary series.
// Arguments:
// size - the length of the string. The system will add one extra
// for a null terminator (not strictly required, but good for C.)
// unicode - set FALSE for ASCII/Latin1 strings, set TRUE for Unicode.
// Notes:
// Strings can be REBYTE or REBCHR sized (depends on R3 config.)
// Strings are allocated with REBOL's internal memory manager.
// Internal structures may change, so NO assumptions should be made!
// Strings are automatically garbage collected if there are
// no references to them from REBOL code (C code does nothing.)
// However, you can lock strings to prevent deallocation. (?? default)
//
RL_API REBSER *RL_Make_String(u32 size, REBOOL unicode)
{
REBSER *result = unicode ? Make_Unicode(size) : Make_Binary(size);
// !!! Assume client does not have Free_Series() or MANAGE_SERIES()
// APIs, so the series we give back must be managed. But how can
// we be sure they get what usage they needed before the GC happens?
MANAGE_SERIES(result);
return result;
}
//
// 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;
}
//
// Complement_Binary: C
//
// Only valid for BINARY data.
//
REBSER *Complement_Binary(REBVAL *value)
{
const REBYTE *bp = VAL_BIN_AT(value);
REBCNT len = VAL_LEN_AT(value);
REBSER *bin = Make_Binary(len);
TERM_SEQUENCE_LEN(bin, len);
REBYTE *dp = BIN_HEAD(bin);
for (; len > 0; len--, ++bp, ++dp)
*dp = ~(*bp);
return bin;
}
*/ REBSER *Decode_UTF_String(REBYTE *bp, REBCNT len, REBINT utf, REBFLG ccr)
/*
** Do all the details to decode a string.
** Input is a byte series. Len is len of input.
** The utf is 0, 8, +/-16, +/-32.
** A special -1 means use the BOM.
**
***********************************************************************/
{
REBSER *ser = BUF_UTF8; // buffer is Unicode width
REBSER *dst;
REBINT size;
//REBFLG ccr = FALSE; // in original R3-alpha if was TRUE
//@@ https://github.com/rebol/rebol-issues/issues/2336
if (utf == -1) {
utf = What_UTF(bp, len);
if (utf) {
if (utf == 8) bp += 3, len -= 3;
else if (utf == -16 || utf == 16) bp += 2, len -= 2;
else if (utf == -32 || utf == 32) bp += 4, len -= 4;
}
}
if (utf == 0 || utf == 8) {
size = Decode_UTF8((REBUNI*)Reset_Buffer(ser, len), bp, len, ccr);
}
else if (utf == -16 || utf == 16) {
size = Decode_UTF16((REBUNI*)Reset_Buffer(ser, len/2 + 1), bp, len, utf < 0, ccr);
}
else if (utf == -32 || utf == 32) {
size = Decode_UTF32((REBUNI*)Reset_Buffer(ser, len/4 + 1), bp, len, utf < 0, ccr);
}
else {
return NULL;
}
if (size < 0) {
size = -size;
dst = Make_Binary(size);
Append_Uni_Bytes(dst, UNI_HEAD(ser), size);
}
else {
dst = Make_Unicode(size);
Append_Uni_Uni(dst, UNI_HEAD(ser), size);
}
return dst;
}
*/ REBSER *Compress(REBSER *input, REBINT index, REBINT len, REBFLG use_crc)
/*
** Compress a binary (only).
** data
** /part
** length
** /crc32
**
** Note: If the file length is "small", it can't overrun on
** compression too much so we use our magic numbers; otherwise,
** we'll just be safe by a percentage of the file size. This may
** be a bit much, though.
**
***********************************************************************/
{
// NOTE: The use_crc flag is not present in Zlib 1.2.8
// Instead, compress's fifth paramter is the compression level
// It can be a value from 1 to 9, or Z_DEFAULT_COMPRESSION if you
// want it to pick what the library author considers the "worth it"
// tradeoff of time to generally suggest.
uLongf size;
REBSER *output;
REBINT err;
REBYTE out_size[sizeof(REBCNT)];
if (len < 0) Trap_DEAD_END(RE_PAST_END); // !!! better msg needed
size = len + (len > STERLINGS_MAGIC_NUMBER ? len / 10 + 12 : STERLINGS_MAGIC_FIX);
output = Make_Binary(size);
//DISABLE_GC; // !!! why??
// dest, dest-len, src, src-len, level
err = z_compress2(BIN_HEAD(output), &size, BIN_HEAD(input) + index, len, Z_DEFAULT_COMPRESSION);
if (err) {
REBVAL arg;
if (err == Z_MEM_ERROR) Trap_DEAD_END(RE_NO_MEMORY);
SET_INTEGER(&arg, err);
Trap1_DEAD_END(RE_BAD_PRESS, &arg); //!!!provide error string descriptions
}
SET_STR_END(output, size);
SERIES_TAIL(output) = size;
REBCNT_To_Bytes(out_size, (REBCNT)len); // Tag the size to the end.
Append_Series(output, (REBYTE*)out_size, sizeof(REBCNT));
if (SERIES_AVAIL(output) > 1024) // Is there wasted space?
output = Copy_Series(output); // Trim it down if too big. !!! Revisit this based on mem alloc alg.
//ENABLE_GC;
return output;
}
*/ REBSER *Xandor_Binary(REBCNT action, REBVAL *value, REBVAL *arg)
/*
** Only valid for BINARY data.
**
***********************************************************************/
{
REBSER *series;
REBYTE *p0 = VAL_BIN_DATA(value);
REBYTE *p1 = VAL_BIN_DATA(arg);
REBYTE *p2;
REBCNT i;
REBCNT mt, t1, t0, t2;
t0 = VAL_LEN(value);
t1 = VAL_LEN(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);
series = Make_Binary(t2);
SERIES_TAIL(series) = t2;
p2 = BIN_HEAD(series);
switch (action) {
case A_AND:
for (i = 0; i < mt; i++) *p2++ = *p0++ & *p1++;
CLEAR(p2, t2 - mt);
return series;
case A_OR:
for (i = 0; i < mt; i++) *p2++ = *p0++ | *p1++;
break;
case A_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;
}
static REBSER *Make_Binary_BE64(REBVAL *arg)
{
REBSER *ser = Make_Binary(9);
REBI64 n = VAL_INT64(arg);
REBINT count;
REBYTE *bp = BIN_HEAD(ser);
for (count = 7; count >= 0; count--) {
bp[count] = (REBYTE)(n & 0xff);
n >>= 8;
}
bp[8] = 0;
ser->tail = 8;
return ser;
}
*/ static void Scan_Error(REBCNT errnum, SCAN_STATE *ss, REBCNT tkn, REBYTE *arg, REBCNT size, REBVAL *relax)
/*
** Scanner error handler
**
***********************************************************************/
{
ERROR_OBJ *error;
REBSER *errs;
REBYTE *name;
REBYTE *cp;
REBYTE *bp;
REBSER *ser;
REBCNT len = 0;
ss->errors++;
if (PG_Boot_Strs)
name = BOOT_STR(RS_SCAN,tkn);
else
name = (REBYTE*)"boot";
cp = ss->head_line;
while (IS_LEX_SPACE(*cp)) cp++; // skip indentation
bp = cp;
while (NOT_NEWLINE(*cp)) cp++, len++;
//DISABLE_GC;
errs = Make_Error(errnum, 0, 0, 0);
error = (ERROR_OBJ *)FRM_VALUES(errs);
ser = Make_Binary(len + 16);
Append_Bytes(ser, "(line ");
Append_Int(ser, ss->line_count);
Append_Bytes(ser, ") ");
Append_Series(ser, (REBYTE*)bp, len);
Set_String(&error->nearest, ser);
Set_String(&error->arg1, Copy_Bytes(name, -1));
Set_String(&error->arg2, Copy_Bytes(arg, size));
if (relax) {
SET_ERROR(relax, errnum, errs);
//ENABLE_GC;
return;
}
Throw_Error(errs); // ENABLE_GC implied
}
*/ void Enable_Backtrace(REBFLG on)
/*
***********************************************************************/
{
if (on) {
if (Trace_Limit == 0) {
Trace_Limit = 100000;
Trace_Buffer = Make_Binary(Trace_Limit);
KEEP_SERIES(Trace_Buffer, "trace-buffer"); // !!! use better way
}
}
else {
if (Trace_Limit) Free_Series(Trace_Buffer);
Trace_Limit = 0;
Trace_Buffer = 0;
}
}
//
// 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;
}
*/ REBSER *Make_Bitset(REBCNT len)
/*
** Return a bitset series (binary.
**
** len: the # of bits in the bitset.
**
***********************************************************************/
{
REBSER *ser;
len = (len + 7) / 8;
ser = Make_Binary(len);
Clear_Series(ser);
SERIES_TAIL(ser) = len;
BITS_NOT(ser) = 0;
return ser;
}
*/ REBSER *Copy_Bytes(const REBYTE *src, REBINT len)
/*
** Create a string series from the given bytes.
** Source is always latin-1 valid. Result is always 8bit.
**
***********************************************************************/
{
REBSER *dst;
if (len < 0) len = LEN_BYTES(src);
dst = Make_Binary(len);
memcpy(STR_DATA(dst), src, len);
SERIES_TAIL(dst) = len;
STR_TERM(dst);
return dst;
}
*/ REBSER *Complement_Binary(REBVAL *value)
/*
** Only valid for BINARY data.
**
***********************************************************************/
{
REBSER *series;
REBYTE *str = VAL_BIN_DATA(value);
REBINT len = VAL_LEN(value);
REBYTE *out;
series = Make_Binary(len);
SERIES_TAIL(series) = len;
out = BIN_HEAD(series);
for (; len > 0; len--)
*out++ = ~ *str++;
return series;
}
*/ REBSER *Compress(REBSER *input, REBINT index, REBINT len, REBFLG use_crc)
/*
** Compress a binary (only).
** data
** /part
** length
** /crc32
**
** Note: If the file length is "small", it can't overrun on
** compression too much so we use our magic numbers; otherwise,
** we'll just be safe by a percentage of the file size. This may
** be a bit much, though.
**
***********************************************************************/
{
REBCNT size;
REBSER *output;
REBINT err;
REBYTE out_size[4];
if (len < 0) Trap0(RE_PAST_END); // !!! better msg needed
size = len + (len > STERLINGS_MAGIC_NUMBER ? len / 10 + 12 : STERLINGS_MAGIC_FIX);
output = Make_Binary(size);
//DISABLE_GC; // !!! why??
// dest, dest-len, src, src-len, level
err = Z_compress2(BIN_HEAD(output), (uLongf*)&size, BIN_HEAD(input) + index, len, use_crc);
if (err) {
if (err == Z_MEM_ERROR) Trap0(RE_NO_MEMORY);
SET_INTEGER(DS_RETURN, err);
Trap1(RE_BAD_PRESS, DS_RETURN); //!!!provide error string descriptions
}
SET_STR_END(output, size);
SERIES_TAIL(output) = size;
Long_To_Bytes(out_size, (REBCNT)len); // Tag the size to the end.
Append_Series(output, (REBYTE*)out_size, 4);
if (SERIES_AVAIL(output) > 1024) // Is there wasted space?
output = Copy_Series(output); // Trim it down if too big. !!! Revisit this based on mem alloc alg.
//ENABLE_GC;
return output;
}
*/ 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 {
*/ 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;
}
RL_API void *RL_Make_String(u32 size, int unicode)
/*
** Allocate a new string or binary series.
**
** Returns:
** A pointer to a string or binary series.
** Arguments:
** size - the length of the string. The system will add one extra
** for a null terminator (not strictly required, but good for C.)
** unicode - set FALSE for ASCII/Latin1 strings, set TRUE for Unicode.
** Notes:
** Strings can be REBYTE or REBCHR sized (depends on R3 config.)
** Strings are allocated with REBOL's internal memory manager.
** Internal structures may change, so NO assumptions should be made!
** Strings are automatically garbage collected if there are
** no references to them from REBOL code (C code does nothing.)
** However, you can lock strings to prevent deallocation. (?? default)
*/
{
return unicode ? Make_Unicode(size) : Make_Binary(size);
}
*/ REBSER *Decompress(const REBYTE *data, REBCNT len, REBCNT limit, REBFLG use_crc)
/*
** Decompress a binary (only).
**
** Rebol's compress/decompress functions store an extra length
** at the tail of the data, to double-check the zlib result
**
***********************************************************************/
{
// NOTE: The use_crc flag is not present in Zlib 1.2.8
// There is no fifth parameter to uncompress matching the fifth to compress
uLongf size;
REBSER *output;
REBINT err;
// Get the size from the end and make the output buffer that size.
if (len <= 4) Trap_DEAD_END(RE_PAST_END); // !!! better msg needed
size = Bytes_To_REBCNT(data + len - sizeof(REBCNT));
// NOTE: You can hit this if you 'make prep' without doing a full rebuild
// (If you 'make clean' and build again and this goes away, it was that)
if (limit && size > limit) Trap_Num(RE_SIZE_LIMIT, size);
output = Make_Binary(size);
//DISABLE_GC;
err = z_uncompress(BIN_HEAD(output), &size, data, len);
if (err) {
REBVAL arg;
if (PG_Boot_Phase < 2) return 0;
if (err == Z_MEM_ERROR) Trap_DEAD_END(RE_NO_MEMORY);
SET_INTEGER(&arg, err);
Trap1_DEAD_END(RE_BAD_PRESS, &arg); //!!!provide error string descriptions
}
SET_STR_END(output, size);
SERIES_TAIL(output) = size;
//ENABLE_GC;
return output;
}
*/ 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;
}
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;
}
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));
}
