508 lines
17 KiB
C
508 lines
17 KiB
C
#ifndef INCLUDED_LISP_H
|
|
#define INCLUDED_LISP_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 __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,
|
|
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; \
|
|
ptrdiff_t ref_count;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
} LispVal;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
char *data;
|
|
size_t length;
|
|
bool is_static;
|
|
} LispString;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
LispString *name;
|
|
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;
|
|
} LispVector;
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
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 {
|
|
void *builtin;
|
|
LispVal *body;
|
|
};
|
|
|
|
LispVal *lexenv;
|
|
} LispFunction;
|
|
|
|
struct HashtableBucket {
|
|
struct HashtableBucket *next;
|
|
uint64_t hash;
|
|
LispVal *key;
|
|
LispVal *value;
|
|
};
|
|
|
|
#define LISP_HASHTABLE_INITIAL_SIZE 32
|
|
#define LISP_HASHTABLE_GROWTH_FACTOR 2
|
|
#define LISP_HASHTABLE_GROWTH_THRESHOLD 0.75f
|
|
#define LISP_HASHTABLE_SHRINK_THRESHOLD 0.25f
|
|
|
|
typedef struct {
|
|
LISP_OBJECT_HEADER;
|
|
|
|
struct HashtableBucket **data;
|
|
size_t table_size;
|
|
size_t count;
|
|
LispVal *eq_fn;
|
|
LispVal *hash_fn;
|
|
} LispHashtable;
|
|
|
|
// #######################
|
|
// # nil, unbound, and t #
|
|
// #######################
|
|
#define LISPVAL(obj) ((LispVal *) (obj))
|
|
|
|
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)
|
|
|
|
// ###################
|
|
// # 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 ATOM(v) (TYPEOF(v) != TYPE_PAIR)
|
|
|
|
inline static bool KEYWORDP(LispVal *v) {
|
|
return SYMBOLP(v) && ((LispSymbol *) v)->name->length
|
|
&& ((LispSymbol *) v)->name->data[0] == ':';
|
|
}
|
|
|
|
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, \
|
|
.ref_count = -1, \
|
|
.data = value, \
|
|
.length = sizeof(value) - 1, \
|
|
.is_static = true, \
|
|
};
|
|
#define DEF_STATIC_SYMBOL(c_name, lisp_name) \
|
|
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
|
|
static LispSymbol _Q##c_name = { \
|
|
.type = TYPE_SYMBOL, \
|
|
.ref_count = -1, \
|
|
.name = &_Q##c_name##_name, \
|
|
.plist = Qnil, \
|
|
.function = Qunbound, \
|
|
.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, c_name, lisp_name, c_args) \
|
|
LispVal *F##c_name c_args; \
|
|
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
|
|
static LispFunction _Q##c_name##_function = { \
|
|
.type = TYPE_FUNCTION, \
|
|
.ref_count = -1, \
|
|
.is_builtin = true, \
|
|
.is_macro = macrop, \
|
|
.builtin = &F##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, \
|
|
.ref_count = -1, \
|
|
.name = &_Q##c_name##_name, \
|
|
.plist = Qnil, \
|
|
.value = Qunbound, \
|
|
.function = LISPVAL(&_Q##c_name##_function), \
|
|
.is_constant = false, \
|
|
}; \
|
|
LispVal *Q##c_name = (LispVal *) &_Q##c_name; \
|
|
LispVal *F##c_name c_args
|
|
#define DEFUN(c_name, lisp_name, c_args) \
|
|
_INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args)
|
|
#define DEFMACRO(c_name, lisp_name, c_args) \
|
|
_INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args)
|
|
|
|
// ###############
|
|
// # Loop macros #
|
|
// ###############
|
|
#define HASHTABLE_FOREACH(key_var, val_var, table, body) \
|
|
{ \
|
|
LispHashtable *__hashtable_foreach_table = (LispHashtable *) table; \
|
|
for (size_t __hashtable_foreach_i = 0; \
|
|
__hashtable_foreach_i < __hashtable_foreach_table->count; \
|
|
++__hashtable_foreach_i) { \
|
|
struct HashtableBucket *__hashtable_foreach_cur = \
|
|
__hashtable_foreach_table->data[__hashtable_foreach_i]; \
|
|
while (__hashtable_foreach_cur) { \
|
|
LispVal *key_var = __hashtable_foreach_cur->key; \
|
|
LispVal *val_var = __hashtable_foreach_cur->value; \
|
|
{body}; \
|
|
__hashtable_foreach_cur = __hashtable_foreach_cur->next; \
|
|
} \
|
|
} \
|
|
}
|
|
#define FOREACH(var, list) \
|
|
for (LispVal *__foreach_cur = list, *var = Fhead(list); \
|
|
!NILP(__foreach_cur); \
|
|
__foreach_cur = Ftail(__foreach_cur), var = Fhead(__foreach_cur))
|
|
#define FOREACH_TAIL(var, list) \
|
|
for (LispVal *var = list; !NILP(var); var = Ftail(var))
|
|
|
|
// #############################
|
|
// # Allocation and references #
|
|
// #############################
|
|
void *lisp_malloc(size_t size);
|
|
void *lisp_realloc(void *old_ptr, size_t size);
|
|
#define lisp_free free
|
|
|
|
inline static void *lisp_ref(void *val) {
|
|
if (!STATICP(val)) {
|
|
++((LispVal *) val)->ref_count;
|
|
}
|
|
return val;
|
|
}
|
|
|
|
inline static void *lisp_float_ref(void *val) {
|
|
if (LISPVAL(val)->ref_count > 0) {
|
|
--LISPVAL(val)->ref_count;
|
|
}
|
|
return val;
|
|
}
|
|
|
|
void _internal_lisp_delete_object(LispVal *val);
|
|
inline static void *lisp_unref(void *val) {
|
|
if (STATICP(val)) {
|
|
return val;
|
|
} else if (LISPVAL(val)->ref_count > 1) {
|
|
--LISPVAL(val)->ref_count;
|
|
return val;
|
|
} else {
|
|
_internal_lisp_delete_object(val);
|
|
return Qnil;
|
|
}
|
|
}
|
|
#define UNREF_INPLACE(variable) \
|
|
{ \
|
|
variable = lisp_unref(variable); \
|
|
}
|
|
inline static void lisp_unref_double_ptr(void **val) {
|
|
lisp_unref(*val);
|
|
}
|
|
#define IGNORE_REF(val) (lisp_unref(lisp_ref(val)))
|
|
|
|
// ################
|
|
// # 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 *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 *args, LispVal *doc, LispVal *lexenv,
|
|
LispVal *body, bool is_macro);
|
|
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
|
|
|
|
// ########################
|
|
// # Utility and internal #
|
|
// ########################
|
|
bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
|
|
|
|
DECLARE_FUNCTION(type_of, (LispVal * obj));
|
|
DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail));
|
|
DECLARE_FUNCTION(hash_string, (LispVal * obj));
|
|
DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2));
|
|
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));
|
|
LispVal *intern(const char *name, size_t length, bool take);
|
|
DECLARE_FUNCTION(intern, (LispVal * name));
|
|
#define INTERN_STATIC(name) (Fintern(STATIC_STRING(name)))
|
|
|
|
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(int len, ...) {
|
|
LispVal *list = Qnil;
|
|
LispVal *end;
|
|
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);
|
|
end = new_end;
|
|
}
|
|
}
|
|
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);
|
|
end = new_end;
|
|
}
|
|
}
|
|
return list;
|
|
}
|
|
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;
|
|
LispSymbol *name;
|
|
LispVal *detail; // function arguments
|
|
LispVal *lexenv; // symbol -> value
|
|
bool enable_handlers;
|
|
LispVal *handlers; // symbol -> (error-var form)
|
|
LispVal *unwind_forms;
|
|
struct CleanupHandlerEntry *cleanup_handlers;
|
|
|
|
jmp_buf start;
|
|
} StackFrame;
|
|
|
|
extern StackFrame *the_stack;
|
|
extern LispVal *Qtoplevel;
|
|
extern LispVal *Qparent_lexenv;
|
|
|
|
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 cancel_cleanup(void *handle);
|
|
#define WITH_PUSH_FRAME(name, detail, inherit, body) \
|
|
stack_enter(name, detail, inherit); \
|
|
if (setjmp(the_stack->start) == 0) { \
|
|
body \
|
|
} \
|
|
stack_leave();
|
|
#define WITH_CLEANUP(var, body) \
|
|
lisp_ref(var); \
|
|
{ \
|
|
void *__with_cleanup_cleanup = register_cleanup( \
|
|
(lisp_cleanup_func_t) & lisp_unref_double_ptr, &(var)); \
|
|
{body}; \
|
|
cancel_cleanup(__with_cleanup_cleanup); \
|
|
lisp_unref(var); \
|
|
}
|
|
|
|
DECLARE_FUNCTION(backtrace, ());
|
|
noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
|
|
|
|
extern LispVal *Qshutdown_signal;
|
|
extern LispVal *Qtype_error;
|
|
extern LispVal *Qread_error;
|
|
extern LispVal *Qeof_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;
|
|
|
|
#define CHECK_TYPE(type, val) \
|
|
if (TYPEOF(val) != type) { \
|
|
Fthrow(Qtype_error, Qnil); \
|
|
}
|
|
|
|
extern LispVal *Vobarray;
|
|
|
|
#define REGISTER_SYMBOL(sym) \
|
|
Fputhash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym)
|
|
#define REGISTER_STATIC_FUNCTION(obj, args, docstr) \
|
|
((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
|
|
{ \
|
|
LispVal *src = STATIC_STRING(args); \
|
|
lisp_ref(src); \
|
|
set_function_args((LispFunction *) (obj), Fread(src)); \
|
|
lisp_unref(src); \
|
|
}
|
|
#define REGISTER_FUNCTION(fn, args, docstr) \
|
|
REGISTER_SYMBOL(fn); \
|
|
REGISTER_STATIC_FUNCTION(((LispSymbol *) Q##fn)->function, args, docstr);
|
|
|
|
void lisp_init(void);
|
|
void lisp_shutdown(void);
|
|
void register_static_function(LispVal *func);
|
|
|
|
extern LispVal *Qbackquote;
|
|
extern LispVal *Qcomma;
|
|
DECLARE_FUNCTION(quote, (LispVal * form));
|
|
|
|
DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
|
|
DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
|
|
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(when, (LispVal * cond, LispVal *t));
|
|
DECLARE_FUNCTION(if, (LispVal * cond, LispVal *t, LispVal *nil));
|
|
DECLARE_FUNCTION(add, (LispVal * n1, LispVal *n2));
|
|
DECLARE_FUNCTION(setq, (LispVal * name, LispVal *value));
|
|
DECLARE_FUNCTION(progn, (LispVal * forms));
|
|
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
|
|
DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body));
|
|
|
|
void debug_dump(FILE *stream, void *obj, bool newline);
|
|
void debug_print_hashtable(FILE *stream, LispVal *table);
|
|
extern LispVal *Qopt;
|
|
extern LispVal *Qkey;
|
|
extern LispVal *Qallow_other_keys;
|
|
extern LispVal *Qrest;
|
|
|
|
#endif
|