831 lines
29 KiB
C
831 lines
29 KiB
C
#ifndef INCLUDED_LISP_H
|
|
#define INCLUDED_LISP_H
|
|
|
|
#include <assert.h>
|
|
#include <refcount/refcount.h>
|
|
#include <setjmp.h>
|
|
#include <stdarg.h>
|
|
#include <stdbool.h>
|
|
#include <stddef.h>
|
|
#include <stdint.h>
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <stdnoreturn.h>
|
|
|
|
#if defined(__has_attribute) && __has_attribute(format)
|
|
# define PRINTF_FORMAT(first, second) \
|
|
__attribute__((format(printf, first, second)))
|
|
#else
|
|
# define PRINTF_FORMAT(first, second)
|
|
#endif
|
|
|
|
// ####################
|
|
// # Basic Structures #
|
|
// ####################
|
|
typedef enum {
|
|
TYPE_STRING,
|
|
TYPE_SYMBOL,
|
|
TYPE_PAIR,
|
|
TYPE_INTEGER,
|
|
TYPE_FLOAT,
|
|
TYPE_VECTOR,
|
|
TYPE_FUNCTION,
|
|
TYPE_HASHTABLE,
|
|
TYPE_USER_POINTER,
|
|
TYPE_PACKAGE,
|
|
N_LISP_TYPES,
|
|
} LispType;
|
|
|
|
struct _TypeNameEntry {
|
|
const char *name;
|
|
size_t len;
|
|
};
|
|
extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES];
|
|
|
|
#define LISP_OBJECT_HEADER \
|
|
LispType type; \
|
|
RefcountEntry refcount
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
} LispVal;
|
|
#define LISPVAL(obj) ((LispVal *) (obj))
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
char *data;
|
|
size_t length;
|
|
bool is_static;
|
|
} LispString;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
LispString *name;
|
|
LispVal *package;
|
|
LispVal *plist;
|
|
LispVal *function;
|
|
LispVal *value;
|
|
bool is_constant;
|
|
} LispSymbol;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
LispVal *head;
|
|
LispVal *tail;
|
|
} LispPair;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
int64_t value;
|
|
} LispInteger;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
long double value;
|
|
} LispFloat;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
LispVal **data;
|
|
size_t length;
|
|
bool is_static;
|
|
} LispVector;
|
|
|
|
typedef void (*lisp_function_ptr_t)(void);
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
LispVal *name;
|
|
LispVal *return_tag;
|
|
LispVal *doc;
|
|
LispVal *args;
|
|
bool is_builtin;
|
|
bool is_macro;
|
|
|
|
size_t n_req;
|
|
LispVal *rargs;
|
|
size_t n_opt;
|
|
LispVal *oargs;
|
|
LispVal *kwargs; // hash table
|
|
bool allow_other_keys;
|
|
LispVal *rest_arg;
|
|
union {
|
|
struct {
|
|
lisp_function_ptr_t builtin;
|
|
bool distinguish_unpassed;
|
|
};
|
|
LispVal *body;
|
|
};
|
|
|
|
LispVal *lexenv;
|
|
} LispFunction;
|
|
|
|
#define LISP_HASHTABLE_INITIAL_SIZE 32
|
|
#define LISP_HASHTABLE_GROWTH_FACTOR 2
|
|
|
|
struct HashtableEntry {
|
|
uint64_t hash;
|
|
LispVal *key;
|
|
LispVal *value;
|
|
};
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
size_t table_size; // number of buckets
|
|
struct HashtableEntry *key_vals; // array of key, hash, value
|
|
size_t count;
|
|
LispVal *eq_fn;
|
|
LispVal *hash_fn;
|
|
} LispHashtable;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
void *data;
|
|
void (*free_func)(void *);
|
|
} LispUserPointer;
|
|
#define USERPTR(type, obj) ((type *) ((LispUserPointer *) (obj))->data)
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
LispString *name;
|
|
LispVal *obarray; // str -> sym
|
|
LispVal *exported_sym_table; // sym -> bool
|
|
LispVal *imported; // list of (package . (str -> bool))
|
|
} LispPackage;
|
|
|
|
// #######################
|
|
// # nil, unbound, and t #
|
|
// #######################
|
|
extern LispSymbol _Qnil;
|
|
extern LispSymbol _Qunbound; // don't intern!
|
|
extern LispSymbol _Qt;
|
|
|
|
#define Qnil (LISPVAL(&_Qnil))
|
|
#define Qunbound (LISPVAL(&_Qunbound))
|
|
#define Qt (LISPVAL(&_Qt))
|
|
|
|
#define LISP_BOOL(v) ((v) ? Qt : Qnil)
|
|
|
|
// ###########################
|
|
// # Other important symbols #
|
|
// ###########################
|
|
extern LispVal *Qbackquote;
|
|
extern LispVal *Qcomma;
|
|
extern LispVal *Qcomma_at;
|
|
extern LispVal *Qmacro;
|
|
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 #
|
|
// ###################
|
|
#define STATICP(v) (LISPVAL(v)->ref_count < 0)
|
|
#define TYPEOF(v) (LISPVAL(v)->type)
|
|
|
|
// only use on symbols!
|
|
#define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_constant)
|
|
|
|
#define NILP(v) (((void *) (v)) == (void *) Qnil)
|
|
#define STRINGP(v) (TYPEOF(v) == TYPE_STRING)
|
|
#define SYMBOLP(v) (TYPEOF(v) == TYPE_SYMBOL)
|
|
#define PAIRP(v) (TYPEOF(v) == TYPE_PAIR)
|
|
#define INTEGERP(v) (TYPEOF(v) == TYPE_INTEGER)
|
|
#define FLOATP(v) (TYPEOF(v) == TYPE_FLOAT)
|
|
#define VECTORP(v) (TYPEOF(v) == TYPE_VECTOR)
|
|
#define FUNCTIONP(v) (TYPEOF(v) == TYPE_FUNCTION)
|
|
#define HASHTABLEP(v) (TYPEOF(v) == TYPE_HASHTABLE)
|
|
#define USER_POINTER_P(v) (TYPEOF(v) == TYPE_USER_POINTER)
|
|
#define PACKAGEP(v) (TYPEOF(v) == TYPE_PACKAGE)
|
|
|
|
#define ATOM(v) (TYPEOF(v) != TYPE_PAIR)
|
|
|
|
inline static bool KEYWORDP(LispVal *v) {
|
|
return SYMBOLP(v) && ((LispSymbol *) v)->package == keyword_package;
|
|
}
|
|
|
|
inline static bool LISTP(LispVal *v) {
|
|
return NILP(v) || PAIRP(v);
|
|
}
|
|
|
|
inline static bool NUMBERP(LispVal *v) {
|
|
return INTEGERP(v) || FLOATP(v);
|
|
}
|
|
|
|
// ##################################
|
|
// # Macros for static declarations #
|
|
// ##################################
|
|
#define DEF_STATIC_STRING(name, value) \
|
|
static LispString name = { \
|
|
.type = TYPE_STRING, \
|
|
.data = value, \
|
|
.length = sizeof(value) - 1, \
|
|
.is_static = true, \
|
|
}
|
|
#define DEF_STATIC_SYMBOL(c_name, lisp_name) \
|
|
DEF_STATIC_STRING(_Q##c_name##_symnamestr, lisp_name); \
|
|
static LispSymbol _Q##c_name = { \
|
|
.type = TYPE_SYMBOL, \
|
|
.name = &_Q##c_name##_symnamestr, \
|
|
.package = Qnil, \
|
|
.plist = Qnil, \
|
|
.function = Qnil, \
|
|
.value = Qunbound, \
|
|
.is_constant = false, \
|
|
}; \
|
|
LispVal *Q##c_name = LISPVAL(&_Q##c_name)
|
|
#define DECLARE_FUNCTION(c_name, args) \
|
|
LispVal *F##c_name args; \
|
|
extern LispVal *Q##c_name
|
|
// The args and doc fields are filled when the function is registered
|
|
#define _INTERNAL_DEFUN_EXTENDED(macrop, du, c_name, lisp_name, c_args, \
|
|
static_kw) \
|
|
static_kw LispVal *F##c_name c_args; \
|
|
DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name); \
|
|
static LispSymbol _Q##c_name; \
|
|
static LispFunction _Q##c_name##_function = { \
|
|
.type = TYPE_FUNCTION, \
|
|
.is_builtin = true, \
|
|
.is_macro = macrop, \
|
|
.builtin = (void (*)(void)) & F##c_name, \
|
|
.distinguish_unpassed = du, \
|
|
.name = LISPVAL(&_Q##c_name), \
|
|
.doc = Qnil, \
|
|
.args = Qnil, \
|
|
.rargs = Qnil, \
|
|
.oargs = Qnil, \
|
|
.rest_arg = Qnil, \
|
|
.kwargs = Qnil, \
|
|
.lexenv = Qnil, \
|
|
}; \
|
|
static LispSymbol _Q##c_name = { \
|
|
.type = TYPE_SYMBOL, \
|
|
.name = &_Q##c_name##_fnnamestr, \
|
|
.package = Qnil, \
|
|
.plist = Qnil, \
|
|
.value = Qunbound, \
|
|
.function = LISPVAL(&_Q##c_name##_function), \
|
|
.is_constant = false, \
|
|
}; \
|
|
LispVal *Q##c_name = (LispVal *) &_Q##c_name; \
|
|
static_kw LispVal *F##c_name c_args
|
|
#define DEFUN(c_name, lisp_name, c_args) \
|
|
_INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, )
|
|
#define DEFUN_DISTINGUISHED(c_name, lisp_name, c_args) \
|
|
_INTERNAL_DEFUN_EXTENDED(false, true, c_name, lisp_name, c_args, )
|
|
#define DEFMACRO(c_name, lisp_name, c_args) \
|
|
_INTERNAL_DEFUN_EXTENDED(true, false, c_name, lisp_name, c_args, )
|
|
#define STATIC_DEFUN(c_name, lisp_name, c_args) \
|
|
_INTERNAL_DEFUN_EXTENDED(false, false, c_name, lisp_name, c_args, static)
|
|
#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_DO_INTERN(sym, pkg) \
|
|
((LispSymbol *) Q##sym)->package = refcount_ref(pkg); \
|
|
puthash(((LispPackage *) pkg)->obarray, \
|
|
LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym);
|
|
#define REGISTER_SYMBOL_INTO(sym, pkg) \
|
|
REGISTER_SYMBOL_NOINTERN(sym) \
|
|
REGISTER_DO_INTERN(sym, pkg)
|
|
#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 #
|
|
// ###############
|
|
#define HT_FOREACH_VALID_INDEX(table, i_var) \
|
|
for (size_t i_var = 0; i_var < ((LispHashtable *) (table))->table_size; \
|
|
++i_var) \
|
|
if (!HASH_SLOT_UNSET_P((table), i_var))
|
|
|
|
#define FOREACH(var, list) \
|
|
for (LispVal *__foreach_cur = list, *var = HEAD(list); \
|
|
!NILP(__foreach_cur); \
|
|
__foreach_cur = TAIL(__foreach_cur), var = HEAD(__foreach_cur))
|
|
#define FOREACH_TAIL(var, list) \
|
|
for (LispVal *var = list; PAIRP(var); var = TAIL(var))
|
|
|
|
// #############################
|
|
// # 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);
|
|
void *lisp_malloc0(size_t size);
|
|
#define lisp_free free
|
|
|
|
void garbage_collect(void);
|
|
|
|
// ################
|
|
// # Constructors #
|
|
// ################
|
|
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 *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);
|
|
LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args,
|
|
LispVal *lexenv, LispVal *body, LispVal *doc,
|
|
bool is_macro);
|
|
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
|
|
LispVal *make_user_pointer(void *data, void (*free_func)(void *));
|
|
#define ALLOC_USERPTR(type, free_func) \
|
|
(make_user_pointer(lisp_malloc(sizeof(type)), &free_func))
|
|
LispVal *make_lisp_package(LispVal *name);
|
|
|
|
LispVal *predicate_for_type(LispType type);
|
|
|
|
// ###############################
|
|
// # 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(equal, (LispVal * obj1, LispVal *obj2));
|
|
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(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));
|
|
|
|
// #####################
|
|
// # Package Functions #
|
|
// #####################
|
|
DECLARE_FUNCTION(packagep, (LispVal * val));
|
|
DECLARE_FUNCTION(make_package, (LispVal * name));
|
|
DECLARE_FUNCTION(package_name, (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(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));
|
|
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);
|
|
|
|
// ########################
|
|
// # Hash Table Functions #
|
|
// ########################
|
|
DECLARE_FUNCTION(hash_table_p, (LispVal * val));
|
|
DECLARE_FUNCTION(make_hash_table, (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));
|
|
struct HashtableDataArray {
|
|
size_t size;
|
|
struct HashtableEntry *entries;
|
|
};
|
|
void free_hash_table_data_array(void *data);
|
|
|
|
// 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(make_vector, (LispVal * size, LispVal *initial_elem));
|
|
DECLARE_FUNCTION(vector, (LispVal * elems));
|
|
DECLARE_FUNCTION(vector_length, (LispVal * vec));
|
|
DECLARE_FUNCTION(aref, (LispVal * vec, LispVal *index));
|
|
DECLARE_FUNCTION(aset, (LispVal * vec, LispVal *index, LispVal *elem));
|
|
DECLARE_FUNCTION(subvector, (LispVal * vec, LispVal *start, LispVal *end));
|
|
|
|
// many vector functions also work on strings
|
|
// ####################
|
|
// # String Functions #
|
|
// ####################
|
|
DECLARE_FUNCTION(stringp, (LispVal * val));
|
|
DECLARE_FUNCTION(string, (LispVal * chars));
|
|
DECLARE_FUNCTION(hash_string, (LispVal * obj));
|
|
DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2));
|
|
DECLARE_FUNCTION(string_to_vector, (LispVal * str));
|
|
LispVal *sprintf_lisp(const char *format, ...) PRINTF_FORMAT(1, 2);
|
|
bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
|
|
|
|
// ########################
|
|
// # 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;
|
|
extern LispVal *Qout_of_bounds_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);
|
|
LispVal *retval = Fintern(kn, package, Qnil);
|
|
refcount_unref(kn);
|
|
return retval;
|
|
}
|
|
#define INTERN_STATIC(name, package) \
|
|
(_internal_INTERN_STATIC((name), sizeof(name) - 1, package))
|
|
|
|
static inline LispVal *const_list(bool do_ref, int len, ...) {
|
|
LispVal *list = Qnil;
|
|
LispVal *end = Qnil;
|
|
va_list args;
|
|
va_start(args, len);
|
|
while (len--) {
|
|
LispVal *elt = va_arg(args, LispVal *);
|
|
if (NILP(list)) {
|
|
list = Fpair(elt, Qnil);
|
|
end = list;
|
|
} else {
|
|
LispVal *new_end = Fpair(elt, Qnil);
|
|
Fsettail(end, new_end);
|
|
refcount_unref(new_end);
|
|
end = new_end;
|
|
}
|
|
if (!do_ref) {
|
|
refcount_unref(((LispPair *) end)->head);
|
|
}
|
|
}
|
|
va_end(args);
|
|
return list;
|
|
}
|
|
static inline LispVal *make_list(size_t len, LispVal **vals) {
|
|
LispVal *list = Qnil;
|
|
LispVal *end;
|
|
for (size_t i = 0; i < len; ++i) {
|
|
if (NILP(list)) {
|
|
list = Fpair(vals[i], Qnil);
|
|
end = list;
|
|
} else {
|
|
LispVal *new_end = Fpair(vals[i], Qnil);
|
|
Fsettail(end, new_end);
|
|
refcount_unref(new_end);
|
|
end = new_end;
|
|
}
|
|
}
|
|
return list;
|
|
}
|
|
static inline LispVal *push_many(LispVal *list, int count, ...) {
|
|
LispVal *new_list = list;
|
|
bool first = true;
|
|
va_list args;
|
|
va_start(args, count);
|
|
while (count--) {
|
|
new_list = Fpair(va_arg(args, LispVal *), new_list);
|
|
if (!first) {
|
|
refcount_unref(((LispPair *) new_list)->tail);
|
|
first = false;
|
|
}
|
|
}
|
|
va_end(args);
|
|
return new_list;
|
|
}
|
|
|
|
static inline void push_to_lexenv(LispVal **lexenv, LispVal *key,
|
|
LispVal *value) {
|
|
LispVal *old = *lexenv;
|
|
*lexenv = push_many(*lexenv, 2, value, key);
|
|
refcount_unref(old);
|
|
}
|
|
|
|
// 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;
|
|
}
|
|
CHECK_TYPE(TYPE_PAIR, list);
|
|
return ((LispPair *) list)->head;
|
|
}
|
|
static inline LispVal *TAIL(LispVal *list) {
|
|
if (NILP(list)) {
|
|
return Qnil;
|
|
}
|
|
CHECK_TYPE(TYPE_PAIR, list);
|
|
return ((LispPair *) list)->tail;
|
|
}
|
|
static inline LispVal *HEAD_SAFE(LispVal *list) {
|
|
if (!PAIRP(list)) {
|
|
return Qnil;
|
|
}
|
|
return ((LispPair *) list)->head;
|
|
}
|
|
static inline LispVal *TAIL_SAFE(LispVal *list) {
|
|
if (!PAIRP(list)) {
|
|
return Qnil;
|
|
}
|
|
return ((LispPair *) list)->tail;
|
|
}
|
|
|
|
static inline double HASH_TABLE_LOAD_FACTOR(void *obj) {
|
|
assert(HASHTABLEP(obj));
|
|
LispHashtable *table = obj;
|
|
return (double) table->count / table->table_size;
|
|
}
|
|
static inline bool HASH_SLOT_UNSET_P(void *obj, size_t i) {
|
|
assert(HASHTABLEP(obj));
|
|
LispHashtable *table = obj;
|
|
return !table->key_vals[i].key;
|
|
}
|
|
static inline LispVal *HASH_KEY(void *obj, size_t i) {
|
|
assert(HASHTABLEP(obj));
|
|
LispHashtable *table = obj;
|
|
return table->key_vals[i].key;
|
|
}
|
|
static inline LispVal *HASH_VALUE(void *obj, size_t i) {
|
|
assert(HASHTABLEP(obj));
|
|
LispHashtable *table = obj;
|
|
return table->key_vals[i].value;
|
|
}
|
|
static inline uint64_t HASH_HASH(void *obj, size_t i) {
|
|
assert(HASHTABLEP(obj));
|
|
LispHashtable *table = obj;
|
|
return table->key_vals[i].hash;
|
|
}
|
|
|
|
// ###################
|
|
// # 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
|