178 lines
4.0 KiB
C
178 lines
4.0 KiB
C
/* Callstack top pointer */
|
|
CELL cs;
|
|
|
|
/* TAGGED currently executing quotation */
|
|
CELL callframe;
|
|
|
|
/* UNTAGGED currently executing word in quotation */
|
|
CELL callframe_scan;
|
|
|
|
/* UNTAGGED end of quotation */
|
|
CELL callframe_end;
|
|
|
|
#define USER_ENV 32
|
|
|
|
#define CARD_OFF_ENV 1 /* for compiling set-slot */
|
|
#define NLX_VECTOR_ENV 2 /* non-local exit hook */
|
|
#define NAMESTACK_ENV 3 /* used by library only */
|
|
#define GLOBAL_ENV 4
|
|
#define BREAK_ENV 5
|
|
#define CATCHSTACK_ENV 6 /* used by library only */
|
|
#define CPU_ENV 7
|
|
#define BOOT_ENV 8
|
|
#define CALLCC_1_ENV 9 /* used by library only */
|
|
#define ARGS_ENV 10
|
|
#define OS_ENV 11
|
|
#define ERROR_ENV 12 /* a marker consed onto kernel errors */
|
|
#define IN_ENV 13
|
|
#define OUT_ENV 14
|
|
#define GEN_ENV 15 /* set to gen_count */
|
|
#define IMAGE_ENV 16 /* image name */
|
|
#define CELL_SIZE_ENV 17 /* sizeof(CELL) */
|
|
|
|
/* TAGGED user environment data; see getenv/setenv prims */
|
|
DLLEXPORT CELL userenv[USER_ENV];
|
|
|
|
/* macros for reading/writing memory, useful when working around
|
|
C's type system */
|
|
INLINE CELL get(CELL where)
|
|
{
|
|
return *((CELL*)where);
|
|
}
|
|
|
|
INLINE void put(CELL where, CELL what)
|
|
{
|
|
*((CELL*)where) = what;
|
|
}
|
|
|
|
INLINE u16 cget(CELL where)
|
|
{
|
|
return *((u16*)where);
|
|
}
|
|
|
|
INLINE void cput(CELL where, u16 what)
|
|
{
|
|
*((u16*)where) = what;
|
|
}
|
|
|
|
INLINE CELL align8(CELL a)
|
|
{
|
|
return (a + 7) & ~7;
|
|
}
|
|
|
|
/* Canonical T object. It's just a word */
|
|
CELL T;
|
|
|
|
#define SLOT(obj,slot) ((obj) + (slot) * CELLS)
|
|
|
|
INLINE CELL tag_header(CELL cell)
|
|
{
|
|
return RETAG(cell << TAG_BITS,OBJECT_TYPE);
|
|
}
|
|
|
|
INLINE CELL untag_header(CELL cell)
|
|
{
|
|
/* if((cell & TAG_MASK) != OBJECT_TYPE)
|
|
critical_error("Corrupt object header",cell); */
|
|
|
|
return cell >> TAG_BITS;
|
|
}
|
|
|
|
INLINE CELL tag_object(void* cell)
|
|
{
|
|
return RETAG(cell,OBJECT_TYPE);
|
|
}
|
|
|
|
INLINE CELL object_type(CELL tagged)
|
|
{
|
|
return untag_header(get(UNTAG(tagged)));
|
|
}
|
|
|
|
INLINE CELL type_of(CELL tagged)
|
|
{
|
|
if(tagged == F)
|
|
return F_TYPE;
|
|
else if(TAG(tagged) == FIXNUM_TYPE)
|
|
return FIXNUM_TYPE;
|
|
else
|
|
return object_type(tagged);
|
|
}
|
|
|
|
void call(CELL quot);
|
|
|
|
void handle_error();
|
|
void interpreter_loop(void);
|
|
void interpreter(void);
|
|
DLLEXPORT void run_callback(CELL quot);
|
|
void run(void);
|
|
void run_toplevel(void);
|
|
void undefined(F_WORD *word);
|
|
void docol(F_WORD *word);
|
|
void dosym(F_WORD *word);
|
|
void primitive_execute(void);
|
|
void primitive_call(void);
|
|
void primitive_ifte(void);
|
|
void primitive_dispatch(void);
|
|
void primitive_getenv(void);
|
|
void primitive_setenv(void);
|
|
void primitive_exit(void);
|
|
void primitive_os_env(void);
|
|
void primitive_eq(void);
|
|
void primitive_millis(void);
|
|
void primitive_type(void);
|
|
void primitive_tag(void);
|
|
void primitive_slot(void);
|
|
void primitive_set_slot(void);
|
|
CELL clone(CELL obj);
|
|
void primitive_clone(void);
|
|
|
|
/* Runtime errors */
|
|
typedef enum
|
|
{
|
|
ERROR_EXPIRED,
|
|
ERROR_IO,
|
|
ERROR_UNDEFINED_WORD,
|
|
ERROR_TYPE,
|
|
ERROR_SIGNAL,
|
|
ERROR_NEGATIVE_ARRAY_SIZE,
|
|
ERROR_C_STRING,
|
|
ERROR_FFI,
|
|
ERROR_HEAP_SCAN,
|
|
ERROR_UNDEFINED_SYMBOL,
|
|
ERROR_USER_INTERRUPT,
|
|
ERROR_DS_UNDERFLOW,
|
|
ERROR_DS_OVERFLOW,
|
|
ERROR_RS_UNDERFLOW,
|
|
ERROR_RS_OVERFLOW,
|
|
ERROR_CS_UNDERFLOW,
|
|
ERROR_CS_OVERFLOW,
|
|
ERROR_OBJECTIVE_C
|
|
} F_ERRORTYPE;
|
|
|
|
/* Are we throwing an error? */
|
|
bool throwing;
|
|
/* When throw_error throws an error, it sets this global and
|
|
longjmps back to the top-level. */
|
|
CELL thrown_error;
|
|
CELL thrown_keep_stacks;
|
|
/* Since longjmp restores registers, we must save all these values. */
|
|
CELL thrown_ds;
|
|
CELL thrown_rs;
|
|
|
|
void fatal_error(char* msg, CELL tagged);
|
|
void critical_error(char* msg, CELL tagged);
|
|
void throw_error(CELL error, bool keep_stacks);
|
|
void early_error(CELL error);
|
|
void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks);
|
|
void memory_protection_error(void *addr, int signal);
|
|
void signal_error(int signal);
|
|
void type_error(CELL type, CELL tagged);
|
|
void primitive_throw(void);
|
|
void primitive_die(void);
|
|
|
|
INLINE void type_check(CELL type, CELL tagged)
|
|
{
|
|
if(type_of(tagged) != type)
|
|
type_error(type,tagged);
|
|
}
|