STOID Mold_Error(REBVAL *value, REB_MOLD *mold, REBFLG molded)
{
ERROR_OBJ *err;
REBVAL *msg; // Error message block
// Protect against recursion. !!!!
if (molded) {
if (VAL_OBJ_FRAME(value) && VAL_ERR_NUM(value) >= RE_NOTE && VAL_ERR_OBJECT(value))
Mold_Object(value, mold);
else {
// Happens if throw or return is molded.
// make error! 0-3
Pre_Mold(value, mold);
Append_Int(mold->series, VAL_ERR_NUM(value));
End_Mold(mold);
}
return;
}
// If it is an unprocessed BREAK, THROW, CONTINUE, RETURN:
if (VAL_ERR_NUM(value) < RE_NOTE || !VAL_ERR_OBJECT(value)) {
VAL_ERR_OBJECT(value) = Make_Error(VAL_ERR_NUM(value), value, 0, 0); // spoofs field
}
err = VAL_ERR_VALUES(value);
// Form: ** <type> Error:
Emit(mold, "** WB", &err->type, RS_ERRS+0);
// Append: error message ARG1, ARG2, etc.
msg = Find_Error_Info(err, 0);
if (msg) {
if (!IS_BLOCK(msg)) Mold_Value(mold, msg, 0);
else {
//start = DSP + 1;
//Reduce_In_Frame(VAL_ERR_OBJECT(value), VAL_BLK_DATA(msg));
//SERIES_TAIL(DS_Series) = DSP + 1;
//Form_Block_Series(DS_Series, start, mold, 0);
Form_Block_Series(VAL_SERIES(msg), 0, mold, VAL_ERR_OBJECT(value));
}
} else
Append_Boot_Str(mold->series, RS_ERRS+1);
Append_Byte(mold->series, '\n');
// Form: ** Where: function
value = &err->where;
if (VAL_TYPE(value) > REB_NONE) {
Append_Boot_Str(mold->series, RS_ERRS+2);
Mold_Value(mold, value, 0);
Append_Byte(mold->series, '\n');
}
// Form: ** Near: location
value = &err->nearest;
if (VAL_TYPE(value) > REB_NONE) {
Append_Boot_Str(mold->series, RS_ERRS+3);
if (IS_STRING(value)) // special case: source file line number
Append_String(mold->series, VAL_SERIES(value), 0, VAL_TAIL(value));
else if (IS_BLOCK(value))
Mold_Simple_Block(mold, VAL_BLK_DATA(value), 60);
Append_Byte(mold->series, '\n');
}
}
*/ RL_API int RL_Start(REBYTE *bin, REBINT len, REBYTE *script, REBINT script_len, REBCNT flags)
/*
** Evaluate the default boot function.
**
** Returns:
** Zero on success, otherwise indicates an error occurred.
** Arguments:
** bin - optional startup code (compressed), can be null
** len - length of above bin
** flags - special flags
** Notes:
** This function completes the startup sequence by calling
** the sys/start function.
**
***********************************************************************/
{
REBVAL *val;
REBSER *ser;
REBOL_STATE state;
const REBVAL *error;
REBVAL start_result;
int result;
REBVAL out;
if (bin) {
ser = Decompress(bin, len, -1, FALSE, FALSE);
if (!ser) return 1;
val = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_HOST);
Val_Init_Binary(val, ser);
}
if (script && script_len > 4) {
/* a 4-byte long payload type at the beginning */
i32 ptype = 0;
REBYTE *data = script + sizeof(ptype);
script_len -= sizeof(ptype);
memcpy(&ptype, script, sizeof(ptype));
if (ptype == 1) {/* COMPRESSed data */
ser = Decompress(data, script_len, -1, FALSE, FALSE);
} else {
ser = Make_Binary(script_len);
if (ser == NULL) {
OS_FREE(script);
return 1;
}
memcpy(BIN_HEAD(ser), data, script_len);
}
OS_FREE(script);
val = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_EMBEDDED);
Val_Init_Binary(val, ser);
}
PUSH_UNHALTABLE_TRAP(&error, &state);
// The first time through the following code 'error' will be NULL, but...
// `raise Error` can longjmp here, so 'error' won't be NULL *if* that happens!
if (error) {
// Save error for EXPLAIN and return it
*Get_System(SYS_STATE, STATE_LAST_ERROR) = *error;
Print_Value(error, 1024, FALSE);
// !!! Whether or not the Rebol interpreter just throws and quits
// in an error case with a bad error code or breaks you into the
// console to debug the environment should be controlled by
// a command line option. Defaulting to returning an error code
// seems better, because kicking into an interactive session can
// cause logging systems to hang. For now we throw instead of
// just quietly returning a code if the script fails, but add
// that option!
// For RE_HALT and all other errors we return the error
// number. Error numbers are not set in stone (currently), but
// are never zero...which is why we can use 0 for success.
return VAL_ERR_NUM(error);
}
if (Do_Sys_Func_Throws(&out, SYS_CTX_FINISH_RL_START, 0)) {
#if !defined(NDEBUG)
if (LEGACY(OPTIONS_EXIT_FUNCTIONS_ONLY))
raise Error_No_Catch_For_Throw(&out);
#endif
if (
IS_NATIVE(&out) && (
VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_QUIT_NATIVE)
|| VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_EXIT_NATIVE)
)
) {
int status;
CATCH_THROWN(&out, &out);
status = Exit_Status_From_Value(&out);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
Shutdown_Core();
OS_EXIT(status);
DEAD_END;
}
raise Error_No_Catch_For_Throw(&out);
}
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
// The convention in the API was to return 0 for success. We use the
// convention (as for FINISH_INIT_CORE) that any non-UNSET! result from
// FINISH_RL_START indicates something went wrong.
if (IS_UNSET(&out))
result = 0;
else {
assert(FALSE); // should not happen (raise an error instead)
Debug_Fmt("** finish-rl-start returned non-NONE!:");
Debug_Fmt("%r", &out);
result = RE_MISC;
}
return result;
}
*/ RL_API int RL_Do_String(int *exit_status, const REBYTE *text, REBCNT flags, RXIARG *result)
/*
** Load a string and evaluate the resulting block.
**
** Returns:
** The datatype of the result if a positive number (or 0 if the
** type has no representation in the "RXT" API). An error code
** if it's a negative number. Two negative numbers are reserved
** for non-error conditions: -1 for halting (e.g. Escape), and
** -2 is reserved for exiting with exit_status set.
**
** Arguments:
** text - A null terminated UTF-8 (or ASCII) string to transcode
** into a block and evaluate.
** flags - set to zero for now
** result - value returned from evaluation, if NULL then result
** will be returned on the top of the stack
**
** Notes:
** This API was from before Rebol's open sourcing and had little
** vetting and few clients. The one client it did have was the
** "sample" console code (which wound up being the "only"
** console code for quite some time).
**
***********************************************************************/
{
REBSER *code;
REBVAL out;
REBOL_STATE state;
const REBVAL *error;
// assumes it can only be run at the topmost level where
// the data stack is completely empty.
assert(DSP == -1);
PUSH_UNHALTABLE_TRAP(&error, &state);
// The first time through the following code 'error' will be NULL, but...
// `raise Error` can longjmp here, so 'error' won't be NULL *if* that happens!
if (error) {
if (VAL_ERR_NUM(error) == RE_HALT)
return -1; // !!! Revisit hardcoded #
// Save error for WHY?
*Get_System(SYS_STATE, STATE_LAST_ERROR) = *error;
if (result)
*result = Value_To_RXI(error);
else
DS_PUSH(error);
return -VAL_ERR_NUM(error);
}
code = Scan_Source(text, LEN_BYTES(text));
PUSH_GUARD_SERIES(code);
// Bind into lib or user spaces?
if (flags) {
// Top words will be added to lib:
Bind_Values_Set_Forward_Shallow(BLK_HEAD(code), Lib_Context);
Bind_Values_Deep(BLK_HEAD(code), Lib_Context);
} else {
REBCNT len;
REBVAL vali;
REBSER *user = VAL_OBJ_FRAME(Get_System(SYS_CONTEXTS, CTX_USER));
len = user->tail;
Bind_Values_All_Deep(BLK_HEAD(code), user);
SET_INTEGER(&vali, len);
Resolve_Context(user, Lib_Context, &vali, FALSE, 0);
}
if (Do_At_Throws(&out, code, 0)) {
DROP_GUARD_SERIES(code);
if (
IS_NATIVE(&out) && (
VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_QUIT_NATIVE)
|| VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_EXIT_NATIVE)
)
) {
CATCH_THROWN(&out, &out);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
*exit_status = Exit_Status_From_Value(&out);
return -2; // Revisit hardcoded #
}
raise Error_No_Catch_For_Throw(&out);
}
DROP_GUARD_SERIES(code);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
if (result)
*result = Value_To_RXI(&out);
else
DS_PUSH(&out);
return Reb_To_RXT[VAL_TYPE(&out)];
}
*/ REBINT Cmp_Value(REBVAL *s, REBVAL *t, REBFLG is_case)
/*
** Compare two values and return the difference.
**
** is_case TRUE for case sensitive compare
**
***********************************************************************/
{
REBDEC d1, d2;
if (VAL_TYPE(t) != VAL_TYPE(s) && !(IS_NUMBER(s) && IS_NUMBER(t)))
return VAL_TYPE(s) - VAL_TYPE(t);
switch(VAL_TYPE(s)) {
case REB_INTEGER:
if (IS_DECIMAL(t)) {
d1 = (REBDEC)VAL_INT64(s);
d2 = VAL_DECIMAL(t);
goto chkDecimal;
}
return THE_SIGN(VAL_INT64(s) - VAL_INT64(t));
case REB_LOGIC:
return VAL_LOGIC(s) - VAL_LOGIC(t);
case REB_CHAR:
if (is_case) return THE_SIGN(VAL_CHAR(s) - VAL_CHAR(t));
return THE_SIGN((REBINT)(UP_CASE(VAL_CHAR(s)) - UP_CASE(VAL_CHAR(t))));
case REB_DECIMAL:
case REB_MONEY:
d1 = VAL_DECIMAL(s);
if (IS_INTEGER(t))
d2 = (REBDEC)VAL_INT64(t);
else
d2 = VAL_DECIMAL(t);
chkDecimal:
if (Eq_Decimal(d1, d2))
return 0;
if (d1 < d2)
return -1;
return 1;
case REB_PAIR:
return Cmp_Pair(s, t);
case REB_EVENT:
return Cmp_Event(s, t);
case REB_GOB:
return Cmp_Gob(s, t);
case REB_TUPLE:
return Cmp_Tuple(s, t);
case REB_TIME:
return Cmp_Time(s, t);
case REB_DATE:
return Cmp_Date(s, t);
case REB_BLOCK:
case REB_PAREN:
case REB_MAP:
case REB_PATH:
case REB_SET_PATH:
case REB_GET_PATH:
case REB_LIT_PATH:
return Cmp_Block(s, t, is_case);
case REB_STRING:
case REB_FILE:
case REB_EMAIL:
case REB_URL:
case REB_TAG:
return Compare_String_Vals(s, t, (REBOOL)!is_case);
case REB_BITSET:
case REB_BINARY:
case REB_IMAGE:
return Compare_Binary_Vals(s, t);
case REB_VECTOR:
return Compare_Vector(s, t);
case REB_DATATYPE:
return VAL_DATATYPE(s) - VAL_DATATYPE(t);
case REB_WORD:
case REB_SET_WORD:
case REB_GET_WORD:
case REB_LIT_WORD:
case REB_REFINEMENT:
case REB_ISSUE:
return Compare_Word(s,t,is_case);
case REB_ERROR:
return VAL_ERR_NUM(s) - VAL_ERR_NUM(s);
case REB_OBJECT:
case REB_MODULE:
case REB_PORT:
return VAL_OBJ_FRAME(s) - VAL_OBJ_FRAME(t);
case REB_NATIVE:
return &VAL_FUNC_CODE(s) - &VAL_FUNC_CODE(t);
case REB_ACTION:
case REB_COMMAND:
case REB_OP:
case REB_FUNCTION:
return VAL_FUNC_BODY(s) - VAL_FUNC_BODY(t);
case REB_NONE:
case REB_UNSET:
case REB_END:
default:
break;
}
return 0;
}
static void Mold_Error(const REBVAL *value, REB_MOLD *mold, REBFLG molded)
{
ERROR_OBJ *err;
REBVAL *msg; // Error message block
REBSER *frame;
// Protect against recursion. !!!!
if (molded) {
if (VAL_OBJ_FRAME(value) && VAL_ERR_NUM(value) >= RE_NOTE && VAL_ERR_OBJECT(value))
Mold_Object(value, mold);
else {
// Happens if throw or return is molded.
// make error! 0-3
Pre_Mold(value, mold);
Append_Int(mold->series, VAL_ERR_NUM(value));
End_Mold(mold);
}
return;
}
if (VAL_ERR_NUM(value) < RE_THROW_MAX) {
// Though we generally do not make error objects for THROWN() errors,
// we do make one here for the purposes of molding.
frame = Make_Error(VAL_ERR_NUM(value), value, 0, 0);
err = ERR_VALUES(frame);
}
else {
frame = VAL_ERR_OBJECT(value);
err = VAL_ERR_VALUES(value);
}
// Form: ** <type> Error:
Emit(mold, "** WB", &err->type, RS_ERRS+0);
// Append: error message ARG1, ARG2, etc.
msg = Find_Error_Info(err, 0);
if (msg) {
if (!IS_BLOCK(msg)) Mold_Value(mold, msg, 0);
else {
//start = DSP + 1;
//Reduce_In_Frame(frame, VAL_BLK_DATA(msg));
//SERIES_TAIL(DS_Series) = DSP + 1;
//Form_Block_Series(DS_Series, start, mold, 0);
Form_Block_Series(VAL_SERIES(msg), 0, mold, frame);
}
} else
Append_Boot_Str(mold->series, RS_ERRS+1);
Append_Byte(mold->series, '\n');
// Form: ** Where: function
value = &err->where;
if (VAL_TYPE(value) > REB_NONE) {
Append_Boot_Str(mold->series, RS_ERRS+2);
Mold_Value(mold, value, 0);
Append_Byte(mold->series, '\n');
}
// Form: ** Near: location
value = &err->nearest;
if (VAL_TYPE(value) > REB_NONE) {
Append_Boot_Str(mold->series, RS_ERRS+3);
if (IS_STRING(value)) // special case: source file line number
Append_String(mold->series, VAL_SERIES(value), 0, VAL_TAIL(value));
else if (IS_BLOCK(value))
Mold_Simple_Block(mold, VAL_BLK_DATA(value), 60);
Append_Byte(mold->series, '\n');
}
}
*/ void Make_Error_Object(REBVAL *arg, REBVAL *value)
/*
** Creates an error object from arg and puts it in value.
** The arg can be a string or an object body block.
** This function is called by MAKE ERROR!.
**
***********************************************************************/
{
REBSER *err; // Error object
ERROR_OBJ *error; // Error object values
REBINT code = 0;
// Create a new error object from another object, including any non-standard fields:
if (IS_ERROR(arg) || IS_OBJECT(arg)) {
err = Merge_Frames(VAL_OBJ_FRAME(ROOT_ERROBJ),
IS_ERROR(arg) ? VAL_OBJ_FRAME(arg) : VAL_ERR_OBJECT(arg));
error = ERR_VALUES(err);
// if (!IS_INTEGER(&error->code)) {
if (!Find_Error_Info(error, &code)) code = RE_INVALID_ERROR;
SET_INTEGER(&error->code, code);
// }
SET_ERROR(value, VAL_INT32(&error->code), err);
return;
}
// Make a copy of the error object template:
err = CLONE_OBJECT(VAL_OBJ_FRAME(ROOT_ERROBJ));
error = ERR_VALUES(err);
SET_NONE(&error->id);
SET_ERROR(value, 0, err);
// If block arg, evaluate object values (checking done later):
// If user set error code, use it to setup type and id fields.
if (IS_BLOCK(arg)) {
DISABLE_GC;
Do_Bind_Block(err, arg); // GC-OK (disabled)
ENABLE_GC;
if (IS_INTEGER(&error->code) && VAL_INT64(&error->code)) {
Set_Error_Type(error);
} else {
if (Find_Error_Info(error, &code)) {
SET_INTEGER(&error->code, code);
}
}
// The error code is not valid:
if (IS_NONE(&error->id)) {
SET_INTEGER(&error->code, RE_INVALID_ERROR);
Set_Error_Type(error);
}
if (VAL_INT64(&error->code) < 100 || VAL_INT64(&error->code) > 1000)
Trap_Arg(arg);
}
// If string arg, setup other fields
else if (IS_STRING(arg)) {
SET_INTEGER(&error->code, RE_USER); // user error
Set_String(&error->arg1, Copy_Series_Value(arg));
Set_Error_Type(error);
}
// No longer allowed:
// else if (IS_INTEGER(arg)) {
// error->code = *arg;
// Set_Error_Type(error);
// }
else
Trap_Arg(arg);
if (!(VAL_ERR_NUM(value) = VAL_INT32(&error->code))) {
Trap_Arg(arg);
}
}
*/ RL_API void RL_Print_TOS(REBCNT flags, REBYTE *marker)
/*
** Print top REBOL stack value to the console. (pending changes)
**
** Returns:
** Nothing
** Arguments:
** flags - special flags (set to zero at this time).
** marker - placed at beginning of line to indicate output.
** Notes:
** This function is used for the main console evaluation
** input loop to print the results of evaluation from stack.
** The REBOL data stack is an abstract structure that can
** change between releases. This function allows the host
** to print the result of processed functions.
** Note that what is printed is actually TOS+1.
** Marker is usually "==" to show output.
** The system/options/result-types determine which values
** are automatically printed.
**
***********************************************************************/
{
REBINT dsp = DSP;
REBVAL *top = DS_VALUE(dsp+1);
REBOL_STATE state;
REBVAL *types;
if (dsp != 0) Debug_Fmt(Str_Stack_Misaligned, dsp);
PUSH_STATE(state, Saved_State);
if (SET_JUMP(state)) {
POP_STATE(state, Saved_State);
Catch_Error(DS_NEXT); // Stores error value here
Out_Value(DS_NEXT, 0, FALSE, 0); // error
DSP = 0;
return;
}
SET_STATE(state, Saved_State);
if (!IS_UNSET(top)) {
if (!IS_ERROR(top)) {
types = Get_System(SYS_OPTIONS, OPTIONS_RESULT_TYPES);
if (IS_TYPESET(types) && TYPE_CHECK(types, VAL_TYPE(top))) {
if (marker) Out_Str(marker, 0);
Out_Value(top, 500, TRUE, 1); // limit, molded
}
// else {
// Out_Str(Get_Type_Name(top), 1);
// }
} else {
if (VAL_ERR_NUM(top) != RE_HALT) {
Out_Value(top, 640, FALSE, 0); // error FORMed
// if (VAL_ERR_NUM(top) > RE_THROW_MAX) {
// Out_Str("** Note: use WHY? for more about this error", 1);
// }
}
}
}
POP_STATE(state, Saved_State);
DSP = 0;
}
//
// Cmp_Value: C
//
// Compare two values and return the difference.
//
// is_case TRUE for case sensitive compare
//
REBINT Cmp_Value(const RELVAL *s, const RELVAL *t, REBOOL is_case)
{
REBDEC d1, d2;
if (VAL_TYPE(t) != VAL_TYPE(s) && !(ANY_NUMBER(s) && ANY_NUMBER(t)))
return VAL_TYPE(s) - VAL_TYPE(t);
assert(NOT_END(s) && NOT_END(t));
switch(VAL_TYPE(s)) {
case REB_INTEGER:
if (IS_DECIMAL(t)) {
d1 = (REBDEC)VAL_INT64(s);
d2 = VAL_DECIMAL(t);
goto chkDecimal;
}
return THE_SIGN(VAL_INT64(s) - VAL_INT64(t));
case REB_LOGIC:
return VAL_LOGIC(s) - VAL_LOGIC(t);
case REB_CHAR:
if (is_case) return THE_SIGN(VAL_CHAR(s) - VAL_CHAR(t));
return THE_SIGN((REBINT)(UP_CASE(VAL_CHAR(s)) - UP_CASE(VAL_CHAR(t))));
case REB_PERCENT:
case REB_DECIMAL:
case REB_MONEY:
if (IS_MONEY(s))
d1 = deci_to_decimal(VAL_MONEY_AMOUNT(s));
else
d1 = VAL_DECIMAL(s);
if (IS_INTEGER(t))
d2 = cast(REBDEC, VAL_INT64(t));
else if (IS_MONEY(t))
d2 = deci_to_decimal(VAL_MONEY_AMOUNT(t));
else
d2 = VAL_DECIMAL(t);
chkDecimal:
if (Eq_Decimal(d1, d2))
return 0;
if (d1 < d2)
return -1;
return 1;
case REB_PAIR:
return Cmp_Pair(s, t);
case REB_EVENT:
return Cmp_Event(s, t);
case REB_GOB:
return Cmp_Gob(s, t);
case REB_TUPLE:
return Cmp_Tuple(s, t);
case REB_TIME:
return Cmp_Time(s, t);
case REB_DATE:
return Cmp_Date(s, t);
case REB_BLOCK:
case REB_GROUP:
case REB_MAP:
case REB_PATH:
case REB_SET_PATH:
case REB_GET_PATH:
case REB_LIT_PATH:
return Cmp_Array(s, t, is_case);
case REB_STRING:
case REB_FILE:
case REB_EMAIL:
case REB_URL:
case REB_TAG:
return Compare_String_Vals(s, t, NOT(is_case));
case REB_BITSET:
case REB_BINARY:
case REB_IMAGE:
return Compare_Binary_Vals(s, t);
case REB_VECTOR:
return Compare_Vector(s, t);
case REB_DATATYPE:
return VAL_TYPE_KIND(s) - VAL_TYPE_KIND(t);
case REB_WORD:
case REB_SET_WORD:
case REB_GET_WORD:
case REB_LIT_WORD:
case REB_REFINEMENT:
case REB_ISSUE:
return Compare_Word(s,t,is_case);
case REB_ERROR:
return VAL_ERR_NUM(s) - VAL_ERR_NUM(t);
case REB_OBJECT:
case REB_MODULE:
case REB_PORT:
return VAL_CONTEXT(s) - VAL_CONTEXT(t);
case REB_FUNCTION:
return VAL_FUNC_PARAMLIST(s) - VAL_FUNC_PARAMLIST(t);
case REB_LIBRARY:
return VAL_LIBRARY(s) - VAL_LIBRARY(t);
case REB_STRUCT:
return Cmp_Struct(s, t);
case REB_BLANK:
case REB_MAX_VOID:
default:
break;
}
return 0;
}