/* 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); }