Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move things arround

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-22 15:37:36 -07:00
parent dfbd60db18
commit 733c4103a3
3 changed files with 2100 additions and 1973 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3436
src/lisp.c
View File

File diff suppressed because it is too large Load Diff

630
src/lisp.h
View File

@ -48,6 +48,7 @@ extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES];
typedef struct {
LISP_OBJECT_HEADER;
} LispVal;
#define LISPVAL(obj) ((LispVal *) (obj))
typedef struct {
LISP_OBJECT_HEADER;
@ -95,17 +96,7 @@ typedef struct {
bool is_static;
} LispVector;
struct OptArgDesc {
size_t index; // only for keywords
LispVal *name;
LispVal *default_form;
LispVal *pred_var;
};
void free_opt_arg_desc(void *obj);
typedef void (*lisp_function_ptr_t)(void);
typedef struct {
LISP_OBJECT_HEADER;
@ -175,8 +166,6 @@ typedef struct {
// #######################
// # nil, unbound, and t #
// #######################
#define LISPVAL(obj) ((LispVal *) (obj))
extern LispSymbol _Qnil;
extern LispSymbol _Qunbound; // don't intern!
extern LispSymbol _Qt;
@ -187,6 +176,27 @@ extern LispSymbol _Qt;
#define LISP_BOOL(v) ((v) ? Qt : Qnil)
// ###########################
// # Other important symbols #
// ###########################
extern LispVal *Qbackquote;
extern LispVal *Qcomma;
extern LispVal *Qcomma_at;
extern LispVal *Qopt;
extern LispVal *Qkey;
extern LispVal *Qallow_other_keys;
extern LispVal *Qrest;
extern LispVal *Qdeclare;
extern LispVal *Qname;
// ############################
// # Global Package Variables #
// ############################
extern LispVal *package_table;
extern LispVal *system_package;
extern LispVal *keyword_package;
extern LispVal *current_package;
// ###################
// # Type predicates #
// ###################
@ -210,11 +220,6 @@ extern LispSymbol _Qt;
#define ATOM(v) (TYPEOF(v) != TYPE_PAIR)
extern LispVal *package_table;
extern LispVal *system_package;
extern LispVal *keyword_package;
extern LispVal *current_package;
inline static bool KEYWORDP(LispVal *v) {
return SYMBOLP(v) && ((LispSymbol *) v)->package == keyword_package;
}
@ -295,6 +300,36 @@ inline static bool NUMBERP(LispVal *v) {
#define STATIC_DEFMACRO(c_name, lisp_name, c_args) \
_INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, static)
// registration
#define REGISTER_SYMBOL_NOINTERN(sym) \
{ \
refcount_init_static(Q##sym); \
refcount_init_static(((LispSymbol *) Q##sym)->name); \
}
#define REGISTER_SYMBOL_INTO(sym, pkg) \
REGISTER_SYMBOL_NOINTERN(sym) \
((LispSymbol *) Q##sym)->package = refcount_ref(pkg); \
puthash(((LispPackage *) pkg)->obarray, \
LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym);
#define REGISTER_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package)
#define REGISTER_STATIC_FUNCTION(name, args, docstr) \
REGISTER_SYMBOL_NOINTERN(name); \
{ \
LispVal *obj = ((LispSymbol *) Q##name)->function; \
refcount_init_static(obj); \
((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
LispVal *src = STATIC_STRING(args); \
LispVal *a = Fread(src, system_package); \
set_function_args((LispFunction *) (obj), a); \
refcount_unref(src); \
refcount_unref(a); \
}
#define REGISTER_FUNCTION(fn, args, docstr) \
REGISTER_STATIC_FUNCTION(fn, args, docstr); \
((LispSymbol *) Q##fn)->package = refcount_ref(system_package); \
puthash(((LispPackage *) system_package)->obarray, \
LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn);
// ###############
// # Loop macros #
// ###############
@ -324,7 +359,6 @@ inline static bool NUMBERP(LispVal *v) {
// #############################
// # Allocation and references #
// #############################
#define GC_EVERY_N_BYTES 1024 * 80
void *lisp_malloc(size_t size);
void *lisp_realloc(void *old_ptr, size_t size);
@ -338,13 +372,11 @@ void garbage_collect(void);
LispVal *make_lisp_string(const char *data, size_t length, bool take,
bool is_static);
#define STATIC_STRING(s) (make_lisp_string((s), sizeof(s) - 1, true, true))
LispVal *sprintf_lisp(const char *format, ...) PRINTF_FORMAT(1, 2);
LispVal *make_lisp_symbol(LispVal *name);
LispVal *make_lisp_pair(LispVal *head, LispVal *tail);
LispVal *make_lisp_integer(intmax_t value);
LispVal *make_lisp_float(long double value);
LispVal *make_lisp_vector(LispVal **data, size_t length);
void set_function_args(LispFunction *func, LispVal *args);
LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args,
LispVal *lexenv, LispVal *body, bool is_macro);
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
@ -353,41 +385,309 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *));
(make_user_pointer(lisp_malloc(sizeof(type)), &free_func))
LispVal *make_lisp_package(LispVal *name);
// ########################
// # Utility and internal #
// ########################
bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
LispVal *predicate_for_type(LispType type);
DECLARE_FUNCTION(make_hashtable, (LispVal * hash_fn, LispVal *eq_fn));
DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail));
DECLARE_FUNCTION(hash_string, (LispVal * obj));
DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2));
// ###############################
// # Initialization and Shutdown #
// ###############################
void lisp_init(void);
void lisp_shutdown(void);
// ###############################
// # General and Misc. Functions #
// ###############################
noreturn DECLARE_FUNCTION(exit, (LispVal * code));
DECLARE_FUNCTION(id, (LispVal * obj));
DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2));
DECLARE_FUNCTION(puthash, (LispVal * table, LispVal *key, LispVal *value));
DECLARE_FUNCTION(gethash, (LispVal * table, LispVal *key, LispVal *def));
DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key));
DECLARE_FUNCTION(hash_table_count, (LispVal * table));
DECLARE_FUNCTION(breakpoint, (LispVal * id));
DECLARE_FUNCTION(not, (LispVal * obj));
DECLARE_FUNCTION(type_of, (LispVal * val));
DECLARE_FUNCTION(user_pointer_p, (LispVal * val));
DECLARE_FUNCTION(print, (LispVal * obj));
DECLARE_FUNCTION(println, (LispVal * obj));
// ##################################
// # Evaluation and Macro Expansion #
// ##################################
DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv));
DECLARE_FUNCTION(eval, (LispVal * form));
DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest));
DECLARE_FUNCTION(apply, (LispVal * function, LispVal *rest));
DECLARE_FUNCTION(macroexpand_1, (LispVal * form, LispVal *lexical_macros));
DECLARE_FUNCTION(macroexpand_toplevel,
(LispVal * form, LispVal *lexical_macros));
DECLARE_FUNCTION(macroexpand_all, (LispVal * form, LispVal *lexical_macros));
// #################
// # Special Forms #
// #################
DECLARE_FUNCTION(quote, (LispVal * form));
DECLARE_FUNCTION(if, (LispVal * cond, LispVal *t, LispVal *nil));
DECLARE_FUNCTION(setq, (LispVal * args));
DECLARE_FUNCTION(progn, (LispVal * forms));
DECLARE_FUNCTION(condition_case, (LispVal * form, LispVal *rest));
DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(defmacro, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
DECLARE_FUNCTION(while, (LispVal * condition, LispVal *body));
DECLARE_FUNCTION(and, (LispVal * rest));
DECLARE_FUNCTION(or, (LispVal * rest));
DECLARE_FUNCTION(in_package, (LispVal * package));
noreturn DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value));
// ######################
// # Function Functions #
// ######################
DECLARE_FUNCTION(functionp, (LispVal * val));
DECLARE_FUNCTION(macrop, (LispVal * val, LispVal *lexical_macros));
DECLARE_FUNCTION(builtinp, (LispVal * val));
DECLARE_FUNCTION(special_form_p, (LispVal * val));
DECLARE_FUNCTION(function_docstr, (LispVal * func));
struct OptArgDesc {
size_t index; // only for keywords
LispVal *name;
LispVal *default_form;
LispVal *pred_var;
};
void free_opt_arg_desc(void *obj);
void set_function_args(LispFunction *func, LispVal *args);
// ###########################
// # Pair and List Functions #
// ###########################
DECLARE_FUNCTION(pairp, (LispVal * val));
DECLARE_FUNCTION(atom, (LispVal * val));
DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail));
DECLARE_FUNCTION(head, (LispVal * list));
DECLARE_FUNCTION(tail, (LispVal * list));
DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head));
DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail));
// lists
DECLARE_FUNCTION(listp, (LispVal * val));
DECLARE_FUNCTION(list_length, (LispVal * list));
DECLARE_FUNCTION(copy_list, (LispVal * list));
DECLARE_FUNCTION(copy_tree, (LispVal * tree));
size_t list_length(LispVal *obj);
// plists
DECLARE_FUNCTION(plist_get,
(LispVal * plist, LispVal *key, LispVal *def, LispVal *pred));
DECLARE_FUNCTION(plist_set, (LispVal * plist, LispVal *key, LispVal *value,
LispVal *pred));
DECLARE_FUNCTION(plist_rem, (LispVal * plist, LispVal *key, LispVal *pred));
DECLARE_FUNCTION(plist_assoc, (LispVal * plist, LispVal *key, LispVal *pred));
// ####################
// # String Functions #
// ####################
DECLARE_FUNCTION(stringp, (LispVal * val));
DECLARE_FUNCTION(hash_string, (LispVal * obj));
DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2));
LispVal *sprintf_lisp(const char *format, ...) PRINTF_FORMAT(1, 2);
bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
// #####################
// # Package Functions #
// #####################
DECLARE_FUNCTION(packagep, (LispVal * val));
DECLARE_FUNCTION(make_package, (LispVal * name));
DECLARE_FUNCTION(package_name, (LispVal * package));
DECLARE_FUNCTION(mapsymbols, (LispVal * func, LispVal *package));
DECLARE_FUNCTION(set_current_package, (LispVal * package));
DECLARE_FUNCTION(register_package, (LispVal * package));
DECLARE_FUNCTION(current_package, (void) );
DECLARE_FUNCTION(set_current_package, (LispVal * package));
DECLARE_FUNCTION(mapsymbols, (LispVal * func, LispVal *package));
DECLARE_FUNCTION(export_symbol, (LispVal * symbol));
DECLARE_FUNCTION(import_package,
(LispVal * source, LispVal *names, LispVal *target));
DECLARE_FUNCTION(make_package, (LispVal * name));
DECLARE_FUNCTION(register_package, (LispVal * package));
DECLARE_FUNCTION(find_package, (LispVal * name));
LispVal *find_package(const char *name, size_t length);
#define FIND_PACKAGE_STATIC(name) (find_package(name, sizeof(name)))
// ####################
// # Symbol Functions #
// ####################
DECLARE_FUNCTION(symbolp, (LispVal * val));
DECLARE_FUNCTION(keywordp, (LispVal * val));
DECLARE_FUNCTION(make_symbol, (LispVal * name));
DECLARE_FUNCTION(symbol_package, (LispVal * symbol));
DECLARE_FUNCTION(symbol_name, (LispVal * symbol));
DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
DECLARE_FUNCTION(symbol_plist, (LispVal * symbol));
DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(exported_symbol_p, (LispVal * symbol));
DECLARE_FUNCTION(intern_soft, (LispVal * name, LispVal *def, LispVal *package,
LispVal *included_too));
LispVal *find_package(const char *name, size_t length);
#define FIND_PACKAGE_STATIC(name) (find_package(name, sizeof(name)))
LispVal *intern(const char *name, size_t length, bool take, LispVal *package,
bool included_too);
DECLARE_FUNCTION(intern,
(LispVal * name, LispVal *package, LispVal *included_too));
LispVal *intern(const char *name, size_t length, bool take, LispVal *package,
bool included_too);
// #######################
// # Hashtable Functions #
// #######################
DECLARE_FUNCTION(hashtablep, (LispVal * val));
DECLARE_FUNCTION(make_hashtable, (LispVal * hash_fn, LispVal *eq_fn));
DECLARE_FUNCTION(copy_hash_table, (LispVal * table));
DECLARE_FUNCTION(hash_table_count, (LispVal * table));
DECLARE_FUNCTION(puthash, (LispVal * table, LispVal *key, LispVal *value));
DECLARE_FUNCTION(gethash, (LispVal * table, LispVal *key, LispVal *def));
DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key));
// Don't ref their return value
LispVal *puthash(LispVal *table, LispVal *key, LispVal *value);
LispVal *gethash(LispVal *table, LispVal *key, LispVal *def);
LispVal *remhash(LispVal *table, LispVal *key);
// #####################
// # Numeric Functions #
// #####################
DECLARE_FUNCTION(integerp, (LispVal * val));
DECLARE_FUNCTION(floatp, (LispVal * val));
DECLARE_FUNCTION(num_eq, (LispVal * n1, LispVal *n2));
DECLARE_FUNCTION(num_gt, (LispVal * n1, LispVal *n2));
DECLARE_FUNCTION(add, (LispVal * args));
DECLARE_FUNCTION(sub, (LispVal * args));
// ####################
// # Vector Functions #
// ####################
DECLARE_FUNCTION(vectorp, (LispVal * val));
DECLARE_FUNCTION(vector, (LispVal * elems));
// ########################
// # Lexenv and the Stack #
// ########################
// used in condition-case
extern LispVal *Qkw_success;
extern LispVal *Qkw_finally;
DECLARE_FUNCTION(backtrace, (void) );
noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
typedef void (*lisp_cleanup_func_t)(void *);
struct CleanupHandlerEntry {
struct CleanupHandlerEntry *next;
lisp_cleanup_func_t fun;
void *data;
};
typedef struct StackFrame {
struct StackFrame *next;
bool hidden;
LispVal *name;
LispVal *return_tag;
LispVal *detail; // function arguments
LispVal *lexenv; // symbol -> value
bool enable_handlers;
LispVal *handlers; // symbol -> (error-var form)
LispVal *unwind_form;
struct CleanupHandlerEntry *cleanup_handlers;
jmp_buf start;
} StackFrame;
#define STACK_EXIT_NORMAL 0
#define STACK_EXIT_THROW 1
extern StackFrame *the_stack;
extern LispVal *stack_return;
extern LispVal *Qtoplevel;
void stack_enter(LispVal *name, LispVal *detail, bool inherit);
void stack_leave(void);
void *register_cleanup(lisp_cleanup_func_t fun, void *data);
void free_double_ptr(void *ptr);
struct UnrefListData {
LispVal **vals;
size_t len;
};
void unref_free_list_double_ptr(void *ptr);
void unref_double_ptr(void *ptr);
void cancel_cleanup(void *handle);
// ################
// # Stack Macros #
// ################
#define WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, \
on_return) \
stack_enter(name, detail, inherit); \
{ \
int __with_push_frame_jmpval = setjmp(the_stack->start); \
if (__with_push_frame_jmpval == STACK_EXIT_NORMAL) { \
body \
} else if (__with_push_frame_jmpval == STACK_EXIT_THROW) { \
on_return; \
refcount_unref(stack_return); \
stack_return = NULL; \
} \
stack_leave(); \
}
#define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, )
#define WITH_PUSH_FRAME(name, detail, inherit, body) \
WITH_PUSH_FRAME_NO_REF(refcount_ref(name), refcount_ref(detail), inherit, \
body)
#define WITH_CLEANUP_DOUBLE_PTR(var, body) \
{ \
void *__with_cleanup_cleanup = register_cleanup( \
(lisp_cleanup_func_t) & unref_double_ptr, &(var)); \
{body}; \
cancel_cleanup(__with_cleanup_cleanup); \
refcount_unref(var); \
}
#define WITH_CLEANUP(var, body) \
{ \
void *__with_cleanup_cleanup = \
register_cleanup(&refcount_unref_as_callback, (var)); \
{body}; \
cancel_cleanup(__with_cleanup_cleanup); \
refcount_unref(var); \
}
#define WITH_CLEANUP_IF_THROW(var, body) \
{ \
void *__with_cleanup_cleanup = \
register_cleanup(&refcount_unref_as_callback, (var)); \
{body}; \
cancel_cleanup(__with_cleanup_cleanup); \
}
// #########################
// # Errors and Conditions #
// #########################
extern LispVal *Qshutdown_signal;
extern LispVal *Qtype_error;
extern LispVal *Qread_error;
extern LispVal *Qeof_error;
extern LispVal *Qunclosed_error;
extern LispVal *Qvoid_variable_error;
extern LispVal *Qvoid_function_error;
extern LispVal *Qcircular_error;
extern LispVal *Qmalformed_lambda_list_error;
extern LispVal *Qargument_error;
extern LispVal *Qinvalid_function_error;
extern LispVal *Qno_applicable_method_error;
extern LispVal *Qreturn_frame_error;
extern LispVal *Qpackage_exists_error;
extern LispVal *Qimport_error;
extern LispVal *Qunknown_package_error;
#define CHECK_TYPE(type, val) \
if (TYPEOF(val) != type) { \
LispVal *inner_list = const_list(false, 1, predicate_for_type(type)); \
LispVal *args = \
const_list(true, 2, inner_list, Ftype_of(LISPVAL(val))); \
refcount_unref(inner_list); \
Fthrow(Qtype_error, args); \
}
// ############################
// # Inline Utility Functions #
// ############################
static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len,
LispVal *package) {
LispVal *kn = make_lisp_string(name, len, true, true);
@ -398,9 +698,6 @@ static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len,
#define INTERN_STATIC(name, package) \
(_internal_INTERN_STATIC((name), sizeof(name) - 1, package))
DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head));
DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail));
size_t list_length(LispVal *obj);
static inline LispVal *const_list(bool do_ref, int len, ...) {
LispVal *list = Qnil;
LispVal *end = Qnil;
@ -455,6 +752,7 @@ static inline LispVal *push_many(LispVal *list, int count, ...) {
va_end(args);
return new_list;
}
static inline void push_to_lexenv(LispVal **lexenv, LispVal *key,
LispVal *value) {
LispVal *old = *lexenv;
@ -462,244 +760,7 @@ static inline void push_to_lexenv(LispVal **lexenv, LispVal *key,
refcount_unref(old);
}
typedef void (*lisp_cleanup_func_t)(void *);
struct CleanupHandlerEntry {
struct CleanupHandlerEntry *next;
lisp_cleanup_func_t fun;
void *data;
};
typedef struct StackFrame {
struct StackFrame *next;
bool hidden;
LispVal *name;
LispVal *return_tag;
LispVal *detail; // function arguments
LispVal *lexenv; // symbol -> value
bool enable_handlers;
LispVal *handlers; // symbol -> (error-var form)
LispVal *unwind_form;
struct CleanupHandlerEntry *cleanup_handlers;
jmp_buf start;
} StackFrame;
#define STACK_EXIT_NORMAL 0
#define STACK_EXIT_THROW 1
extern StackFrame *the_stack;
extern LispVal *stack_return;
extern LispVal *Qtoplevel;
void stack_enter(LispVal *name, LispVal *detail, bool inherit);
void stack_leave(void);
void *register_cleanup(lisp_cleanup_func_t fun, void *data);
void free_double_ptr(void *ptr);
struct UnrefListData {
LispVal **vals;
size_t len;
};
void unref_free_list_double_ptr(void *ptr);
void unref_double_ptr(void *ptr);
void cancel_cleanup(void *handle);
#define WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, \
on_return) \
stack_enter(name, detail, inherit); \
{ \
int __with_push_frame_jmpval = setjmp(the_stack->start); \
if (__with_push_frame_jmpval == STACK_EXIT_NORMAL) { \
body \
} else if (__with_push_frame_jmpval == STACK_EXIT_THROW) { \
on_return; \
refcount_unref(stack_return); \
stack_return = NULL; \
} \
stack_leave(); \
}
#define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, )
#define WITH_PUSH_FRAME(name, detail, inherit, body) \
WITH_PUSH_FRAME_NO_REF(refcount_ref(name), refcount_ref(detail), inherit, \
body)
#define WITH_CLEANUP_DOUBLE_PTR(var, body) \
{ \
void *__with_cleanup_cleanup = register_cleanup( \
(lisp_cleanup_func_t) & unref_double_ptr, &(var)); \
{body}; \
cancel_cleanup(__with_cleanup_cleanup); \
refcount_unref(var); \
}
#define WITH_CLEANUP(var, body) \
{ \
void *__with_cleanup_cleanup = \
register_cleanup(&refcount_unref_as_callback, (var)); \
{body}; \
cancel_cleanup(__with_cleanup_cleanup); \
refcount_unref(var); \
}
#define WITH_CLEANUP_IF_THROW(var, body) \
{ \
void *__with_cleanup_cleanup = \
register_cleanup(&refcount_unref_as_callback, (var)); \
{body}; \
cancel_cleanup(__with_cleanup_cleanup); \
}
DECLARE_FUNCTION(backtrace, (void) );
noreturn DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value));
noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
extern LispVal *Qkw_success;
extern LispVal *Qkw_finally;
extern LispVal *Qshutdown_signal;
extern LispVal *Qtype_error;
extern LispVal *Qread_error;
extern LispVal *Qeof_error;
extern LispVal *Qunclosed_error;
extern LispVal *Qvoid_variable_error;
extern LispVal *Qvoid_function_error;
extern LispVal *Qcircular_error;
extern LispVal *Qmalformed_lambda_list_error;
extern LispVal *Qargument_error;
extern LispVal *Qinvalid_function_error;
extern LispVal *Qno_applicable_method_error;
extern LispVal *Qreturn_frame_error;
extern LispVal *Qpackage_exists_error;
extern LispVal *Qunknown_package_error;
extern LispVal *Qimport_error;
LispVal *predicate_for_type(LispType type);
#define CHECK_TYPE(type, val) \
if (TYPEOF(val) != type) { \
LispVal *inner_list = const_list(false, 1, predicate_for_type(type)); \
LispVal *args = \
const_list(true, 2, inner_list, Ftype_of(LISPVAL(val))); \
refcount_unref(inner_list); \
Fthrow(Qtype_error, args); \
}
#define REGISTER_SYMBOL_NOINTERN(sym) \
{ \
refcount_init_static(Q##sym); \
refcount_init_static(((LispSymbol *) Q##sym)->name); \
}
#define REGISTER_SYMBOL_INTO(sym, pkg) \
REGISTER_SYMBOL_NOINTERN(sym) \
((LispSymbol *) Q##sym)->package = refcount_ref(pkg); \
puthash(((LispPackage *) pkg)->obarray, \
LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym);
#define REGISTER_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package)
#define REGISTER_STATIC_FUNCTION(name, args, docstr) \
REGISTER_SYMBOL_NOINTERN(name); \
{ \
LispVal *obj = ((LispSymbol *) Q##name)->function; \
refcount_init_static(obj); \
((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
LispVal *src = STATIC_STRING(args); \
LispVal *a = Fread(src, system_package); \
set_function_args((LispFunction *) (obj), a); \
refcount_unref(src); \
refcount_unref(a); \
}
#define REGISTER_FUNCTION(fn, args, docstr) \
REGISTER_STATIC_FUNCTION(fn, args, docstr); \
((LispSymbol *) Q##fn)->package = refcount_ref(system_package); \
puthash(((LispPackage *) system_package)->obarray, \
LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn);
void lisp_init(void);
void lisp_shutdown(void);
void register_static_function(LispVal *func);
extern LispVal *Qbackquote;
extern LispVal *Qcomma;
extern LispVal *Qcomma_at;
DECLARE_FUNCTION(quote, (LispVal * form));
DECLARE_FUNCTION(breakpoint, (LispVal * id));
DECLARE_FUNCTION(symbol_package, (LispVal * symbol));
DECLARE_FUNCTION(symbol_name, (LispVal * symbol));
DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
DECLARE_FUNCTION(symbol_plist, (LispVal * symbol));
DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist));
DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv));
DECLARE_FUNCTION(eval, (LispVal * form));
DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest));
DECLARE_FUNCTION(apply, (LispVal * function, LispVal *rest));
DECLARE_FUNCTION(head, (LispVal * list));
DECLARE_FUNCTION(tail, (LispVal * list));
noreturn DECLARE_FUNCTION(exit, (LispVal * code));
DECLARE_FUNCTION(print, (LispVal * obj));
DECLARE_FUNCTION(println, (LispVal * obj));
DECLARE_FUNCTION(not, (LispVal * obj));
DECLARE_FUNCTION(if, (LispVal * cond, LispVal *t, LispVal *nil));
DECLARE_FUNCTION(add, (LispVal * args));
DECLARE_FUNCTION(sub, (LispVal * args));
DECLARE_FUNCTION(setq, (LispVal * args));
DECLARE_FUNCTION(progn, (LispVal * forms));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(condition_case, (LispVal * form, LispVal *rest));
DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(defmacro, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
DECLARE_FUNCTION(while, (LispVal * condition, LispVal *body));
DECLARE_FUNCTION(make_symbol, (LispVal * name));
DECLARE_FUNCTION(macroexpand_1, (LispVal * form, LispVal *lexical_macros));
DECLARE_FUNCTION(macroexpand_toplevel,
(LispVal * form, LispVal *lexical_macros));
DECLARE_FUNCTION(macroexpand_all, (LispVal * form, LispVal *lexical_macros));
DECLARE_FUNCTION(stringp, (LispVal * val));
DECLARE_FUNCTION(symbolp, (LispVal * val));
DECLARE_FUNCTION(pairp, (LispVal * val));
DECLARE_FUNCTION(integerp, (LispVal * val));
DECLARE_FUNCTION(floatp, (LispVal * val));
DECLARE_FUNCTION(vectorp, (LispVal * val));
DECLARE_FUNCTION(packagep, (LispVal * val));
DECLARE_FUNCTION(functionp, (LispVal * val));
DECLARE_FUNCTION(macrop, (LispVal * val, LispVal *lexical_macros));
DECLARE_FUNCTION(builtinp, (LispVal * val));
DECLARE_FUNCTION(special_form_p, (LispVal * val));
DECLARE_FUNCTION(hashtablep, (LispVal * val));
DECLARE_FUNCTION(user_pointer_p, (LispVal * val));
DECLARE_FUNCTION(atom, (LispVal * val));
DECLARE_FUNCTION(listp, (LispVal * val));
DECLARE_FUNCTION(keywordp, (LispVal * val));
DECLARE_FUNCTION(numberp, (LispVal * val));
DECLARE_FUNCTION(list_length, (LispVal * list));
DECLARE_FUNCTION(copy_list, (LispVal * list));
DECLARE_FUNCTION(copy_tree, (LispVal * tree));
DECLARE_FUNCTION(num_eq, (LispVal * n1, LispVal *n2));
DECLARE_FUNCTION(num_gt, (LispVal * n1, LispVal *n2));
DECLARE_FUNCTION(and, (LispVal * rest));
DECLARE_FUNCTION(or, (LispVal * rest));
DECLARE_FUNCTION(type_of, (LispVal * val));
DECLARE_FUNCTION(function_docstr, (LispVal * func));
DECLARE_FUNCTION(plist_get,
(LispVal * plist, LispVal *key, LispVal *def, LispVal *pred));
DECLARE_FUNCTION(plist_set, (LispVal * plist, LispVal *key, LispVal *value,
LispVal *pred));
DECLARE_FUNCTION(plist_rem, (LispVal * plist, LispVal *key, LispVal *pred));
DECLARE_FUNCTION(plist_assoc, (LispVal * plist, LispVal *key, LispVal *pred));
void debug_dump(FILE *stream, void *obj, bool newline);
void debug_print_hashtable(FILE *stream, LispVal *table);
void debug_print_tree(FILE *stream, void *obj);
void debug_dump_lexenv(FILE *stream, LispVal *lexenv);
extern LispVal *Qopt;
extern LispVal *Qkey;
extern LispVal *Qallow_other_keys;
extern LispVal *Qrest;
extern LispVal *Qdeclare;
extern LispVal *Qname;
// some internal functions
LispVal *puthash(LispVal *table, LispVal *key, LispVal *value);
LispVal *gethash(LispVal *table, LispVal *key, LispVal *def);
LispVal *remhash(LispVal *table, LispVal *key);
// These are like the internal functions, but they don't ref their return value
static inline LispVal *HEAD(LispVal *list) {
if (NILP(list)) {
return Qnil;
@ -727,4 +788,11 @@ static inline LispVal *TAIL_SAFE(LispVal *list) {
return ((LispPair *) list)->tail;
}
// ###################
// # Debug Functions #
// ###################
void debug_dump(FILE *stream, void *obj, bool newline);
void debug_print_hashtable(FILE *stream, LispVal *table);
void debug_print_tree(FILE *stream, void *obj);
#endif

1
src/main.c
View File

@ -60,6 +60,7 @@ int main(int argc, const char **argv) {
REGISTER_STATIC_FUNCTION(toplevel_exit_handler, "(e)", "");
size_t pos = 0;
WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
the_stack->hidden = false;
LispVal *err_var = INTERN_STATIC("err-var", system_package);
puthash(the_stack->handlers, Qt,
// simply call the above function