*/ ATTRIBUTE_NO_RETURN static void Error_Compression(const z_stream *strm, int ret)
/*
** Zlib gives back string error messages. We use them or fall
** back on the integer code if there is no message.
**
***********************************************************************/
{
REBVAL arg;
if (ret == Z_MEM_ERROR) {
// We do not technically know the amount of memory that zlib asked
// for and did not get. Hence categorizing it as an "out of memory"
// error might be less useful than leaving as a compression error,
// but that is what the old code here historically did.
raise Error_No_Memory(0);
}
if (strm->msg)
Val_Init_String(
&arg, Copy_Bytes(cb_cast(strm->msg), strlen(strm->msg))
);
else
SET_INTEGER(&arg, ret);
Error_1(RE_BAD_COMPRESSION, &arg);
}
*/ 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
}
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);
}
*/ REBSER *Encode_UTF8_String(void *src, REBCNT len, REBFLG uni, REBFLG opts)
/*
** Do all the details to encode a string as UTF8.
** No_copy means do not make a copy.
** Result can be a shared buffer!
**
***********************************************************************/
{
REBSER *ser = BUF_FORM; // a shared buffer
REBCNT size;
REBYTE *cp;
REBFLG ccr = GET_FLAG(opts, ENC_OPT_CRLF);
if (uni) {
REBUNI *up = (REBUNI*)src;
size = Length_As_UTF8(up, len, TRUE, (REBOOL)ccr);
cp = Reset_Buffer(ser, size + (GET_FLAG(opts, ENC_OPT_BOM) ? 3 : 0));
UNUSED(cp);
Encode_UTF8(Reset_Buffer(ser, size), size, up, &len, TRUE, ccr);
}
else {
REBYTE *bp = (REBYTE*)src;
if (Is_Not_ASCII(bp, len)) {
size = Length_As_UTF8((REBUNI*)bp, len, FALSE, (REBOOL)ccr);
cp = Reset_Buffer(ser, size + (GET_FLAG(opts, ENC_OPT_BOM) ? 3 : 0));
Encode_UTF8(cp, size, bp, &len, FALSE, ccr);
}
else if (GET_FLAG(opts, ENC_OPT_NO_COPY)) return 0;
else return Copy_Bytes(bp, len);
}
SERIES_TAIL(ser) = len;
STR_TERM(ser);
return Copy_Bytes(BIN_HEAD(ser), len);
}
static int
p_lock_pass_(value vl, type tl, value v, type t)
{
module_item *m;
Check_Module_And_Access(v, t);
Check_String(tl);
DidModule(v.did) = SOFT_LOCK_MODULE;
m = ModuleItem(v.did);
/* the string should be stored crypted */
m->lock = (char *) hg_alloc((int) StringLength(vl) + 1);
Copy_Bytes(m->lock, StringStart(vl), StringLength(vl) + 1);
Succeed_;
}
//
// RL_Extend: C
//
// Appends embedded extension to system/catalog/boot-exts.
//
// Returns:
// A pointer to the REBOL library (see reb-lib.h).
// Arguments:
// source - A pointer to a UTF-8 (or ASCII) string that provides
// extension module header, function definitions, and other
// related functions and data.
// call - A pointer to the extension's command dispatcher.
// Notes:
// This function simply adds the embedded extension to the
// boot-exts list. All other processing and initialization
// happens later during startup. Each embedded extension is
// queried and init using LOAD-EXTENSION system native.
// See c:extensions-embedded
//
RL_API void *RL_Extend(const REBYTE *source, RXICAL call)
{
REBVAL *value;
REBARR *array;
value = CTX_VAR(Sys_Context, SYS_CTX_BOOT_EXTS);
if (IS_BLOCK(value))
array = VAL_ARRAY(value);
else {
array = Make_Array(2);
Val_Init_Block(value, array);
}
value = Alloc_Tail_Array(array);
Val_Init_Binary(value, Copy_Bytes(source, -1)); // UTF-8
value = Alloc_Tail_Array(array);
SET_HANDLE_CODE(value, cast(CFUNC*, call));
return Extension_Lib();
}
*/ RL_API void *RL_Extend(const REBYTE *source, RXICAL call)
/*
** Appends embedded extension to system/catalog/boot-exts.
**
** Returns:
** A pointer to the REBOL library (see reb-lib.h).
** Arguments:
** source - A pointer to a UTF-8 (or ASCII) string that provides
** extension module header, function definitions, and other
** related functions and data.
** call - A pointer to the extension's command dispatcher.
** Notes:
** This function simply adds the embedded extension to the
** boot-exts list. All other processing and initialization
** happens later during startup. Each embedded extension is
** queried and init using LOAD-EXTENSION system native.
** See c:extensions-embedded
**
***********************************************************************/
{
REBVAL *value;
REBSER *ser;
value = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_EXTS);
if (IS_BLOCK(value)) ser = VAL_SERIES(value);
else {
ser = Make_Array(2);
Val_Init_Block(value, ser);
}
value = Alloc_Tail_Array(ser);
Val_Init_Binary(value, Copy_Bytes(source, -1)); // UTF-8
value = Alloc_Tail_Array(ser);
SET_HANDLE_CODE(value, cast(CFUNC*, call));
return Extension_Lib();
}
static REBSER *make_binary(REBVAL *arg, REBOOL make)
{
REBSER *ser;
// MAKE BINARY! 123
switch (VAL_TYPE(arg)) {
case REB_INTEGER:
case REB_DECIMAL:
if (make) ser = Make_Binary(Int32s(arg, 0));
else ser = Make_Binary_BE64(arg);
break;
// MAKE/TO BINARY! BINARY!
case REB_BINARY:
ser = Copy_Bytes(VAL_BIN_DATA(arg), VAL_LEN(arg));
break;
// MAKE/TO BINARY! <any-string>
case REB_STRING:
case REB_FILE:
case REB_EMAIL:
case REB_URL:
case REB_TAG:
// case REB_ISSUE:
ser = Encode_UTF8_Value(arg, VAL_LEN(arg), 0);
break;
case REB_BLOCK:
ser = Join_Binary(arg);
break;
// MAKE/TO BINARY! <tuple!>
case REB_TUPLE:
ser = Copy_Bytes(VAL_TUPLE(arg), VAL_TUPLE_LEN(arg));
break;
// MAKE/TO BINARY! <char!>
case REB_CHAR:
ser = Make_Binary(6);
ser->tail = Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg));
break;
// MAKE/TO BINARY! <bitset!>
case REB_BITSET:
ser = Copy_Bytes(VAL_BIN(arg), VAL_TAIL(arg));
break;
// MAKE/TO BINARY! <image!>
case REB_IMAGE:
ser = Make_Image_Binary(arg);
break;
case REB_MONEY:
ser = Make_Binary(12);
ser->tail = 12;
deci_to_binary(ser->data, VAL_DECI(arg));
ser->data[12] = 0;
break;
default:
ser = 0;
}
return ser;
}
*/ static REB_R Console_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
***********************************************************************/
{
REBREQ *req;
REBINT result;
REBVAL *arg = D_ARG(2);
REBSER *ser;
Validate_Port(port, action);
arg = D_ARG(2);
*D_OUT = *D_ARG(1);
req = cast(REBREQ*, Use_Port_State(port, RDI_STDIO, sizeof(REBREQ)));
switch (action) {
case A_READ:
// If not open, open it:
if (!IS_OPEN(req)) {
if (OS_DO_DEVICE(req, RDC_OPEN)) Trap_Port_DEAD_END(RE_CANNOT_OPEN, port, req->error);
}
// If no buffer, create a buffer:
arg = OFV(port, STD_PORT_DATA);
if (!IS_STRING(arg) && !IS_BINARY(arg)) {
Set_Binary(arg, MAKE_OS_BUFFER(OUT_BUF_SIZE));
}
ser = VAL_SERIES(arg);
RESET_SERIES(ser);
req->common.data = BIN_HEAD(ser);
req->length = SERIES_AVAIL(ser);
#ifdef nono
// Is the buffer large enough?
req->length = SERIES_AVAIL(ser); // space available
if (req->length < OUT_BUF_SIZE/2) Extend_Series(ser, OUT_BUF_SIZE);
req->length = SERIES_AVAIL(ser);
// Don't make buffer too large: Bug #174 ?????
if (req->length > 1024) req->length = 1024; //???
req->common.data = STR_TAIL(ser); // write at tail //???
if (SERIES_TAIL(ser) == 0) req->actual = 0; //???
#endif
result = OS_DO_DEVICE(req, RDC_READ);
if (result < 0) Trap_Port_DEAD_END(RE_READ_ERROR, port, req->error);
#ifdef nono
// Does not belong here!!
// Remove or replace CRs:
result = 0;
for (n = 0; n < req->actual; n++) {
chr = GET_ANY_CHAR(ser, n);
if (chr == CR) {
chr = LF;
// Skip LF if it follows:
if ((n+1) < req->actual &&
LF == GET_ANY_CHAR(ser, n+1)) n++;
}
SET_ANY_CHAR(ser, result, chr);
result++;
}
#endif
// !!! Among many confusions in this file, it said "Another copy???"
//Set_String(D_OUT, Copy_OS_Str(ser->data, result));
Set_Binary(D_OUT, Copy_Bytes(req->common.data, req->actual));
break;
case A_OPEN:
// ?? why???
//if (OS_DO_DEVICE(req, RDC_OPEN)) Trap_Port_DEAD_END(RE_CANNOT_OPEN, port);
SET_OPEN(req);
break;
case A_CLOSE:
SET_CLOSED(req);
//OS_DO_DEVICE(req, RDC_CLOSE);
break;
case A_OPENQ:
if (IS_OPEN(req)) return R_TRUE;
return R_FALSE;
default:
Trap_Action_DEAD_END(REB_PORT, action);
}
return R_OUT;
}
static REBSER *make_binary(const REBVAL *arg, REBOOL make)
{
REBSER *ser;
// MAKE BINARY! 123
switch (VAL_TYPE(arg)) {
case REB_INTEGER:
case REB_DECIMAL:
if (make) ser = Make_Binary(Int32s(arg, 0));
else ser = Make_Binary_BE64(arg);
break;
// MAKE/TO BINARY! BINARY!
case REB_BINARY:
ser = Copy_Bytes(VAL_BIN_AT(arg), VAL_LEN_AT(arg));
break;
// MAKE/TO BINARY! <any-string>
case REB_STRING:
case REB_FILE:
case REB_EMAIL:
case REB_URL:
case REB_TAG:
// case REB_ISSUE:
ser = Make_UTF8_From_Any_String(arg, VAL_LEN_AT(arg), 0);
break;
case REB_BLOCK:
// Join_Binary returns a shared buffer, so produce a copy:
ser = Copy_Sequence(Join_Binary(arg, -1));
break;
// MAKE/TO BINARY! <tuple!>
case REB_TUPLE:
ser = Copy_Bytes(VAL_TUPLE(arg), VAL_TUPLE_LEN(arg));
break;
// MAKE/TO BINARY! <char!>
case REB_CHAR:
ser = Make_Binary(6);
TERM_SEQUENCE_LEN(ser, Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg)));
break;
// MAKE/TO BINARY! <bitset!>
case REB_BITSET:
ser = Copy_Bytes(VAL_BIN(arg), VAL_LEN_HEAD(arg));
break;
// MAKE/TO BINARY! <image!>
case REB_IMAGE:
ser = Make_Image_Binary(arg);
break;
case REB_MONEY:
ser = Make_Binary(12);
deci_to_binary(BIN_HEAD(ser), VAL_MONEY_AMOUNT(arg));
TERM_SEQUENCE_LEN(ser, 12);
break;
default:
ser = 0;
}
return ser;
}
