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

Basic evaluation, exceptions, and the stack

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-06-30 23:29:02 +09:00
parent 5b6bd50f45
commit 40f717277d
3 changed files with 646 additions and 79 deletions
Download Patch File Download Diff File Expand all files Collapse all files

484
src/lisp.c
View File

@ -6,7 +6,6 @@
#include <string.h>
struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_NULL] = {"null", sizeof("null") - 1},
[TYPE_STRING] = {"string", sizeof("string") - 1},
[TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1},
[TYPE_PAIR] = {"pair", sizeof("pair") - 1},
@ -17,9 +16,15 @@ struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
};
LispVal _Qnil = {
.type = TYPE_NULL,
DEF_STATIC_STRING(_Qnil_name, "nil");
LispSymbol _Qnil = {
.type = TYPE_SYMBOL,
.ref_count = -1,
.name = &_Qnil_name,
.plist = Qnil,
.function = Qunbound,
.value = Qnil,
.is_constant = true,
};
DEF_STATIC_STRING(_Qunbound_name, "unbound");
@ -30,6 +35,7 @@ LispSymbol _Qunbound = {
.plist = Qnil,
.function = Qunbound,
.value = Qunbound,
.is_constant = true,
};
DEF_STATIC_STRING(_Qt_name, "t");
@ -39,16 +45,15 @@ LispSymbol _Qt = {
.name = &_Qt_name,
.plist = Qnil,
.function = Qunbound,
.value = Qunbound,
.value = Qt,
.is_constant = true,
};
DEF_STATIC_SYMBOL(quote, "'");
DEF_STATIC_SYMBOL(backquote, "`");
DEF_STATIC_SYMBOL(comma, ",");
void _internal_lisp_delete_object(LispVal *val) {
switch (TYPEOF(val)) {
case TYPE_NULL:
case TYPE_INTEGER:
case TYPE_FLOAT:
lisp_free(val);
@ -81,9 +86,20 @@ void _internal_lisp_delete_object(LispVal *val) {
lisp_free(vec->data);
lisp_free(val);
} break;
case TYPE_FUNCTION:
// TODO handle
break;
case TYPE_FUNCTION: {
LispFunction *fn = (LispFunction *) val;
lisp_unref(fn->doc);
lisp_unref(fn->args);
for (size_t i = 0; i < fn->n_kw; ++i) {
lisp_unref(fn->kwargs[i]);
}
lisp_free(fn->kwargs);
if (!fn->is_builtin) {
lisp_unref(fn->body);
}
lisp_unref(fn->lexenv);
lisp_free(val);
} break;
case TYPE_HASHTABLE: {
LispHashtable *tbl = (LispHashtable *) val;
for (size_t i = 0; i < tbl->table_size; ++i) {
@ -121,13 +137,6 @@ void *lisp_realloc(void *old_ptr, size_t size) {
return new_ptr;
}
char *lisp_strdup(const char *str) {
size_t len = strlen(str);
char *new_str = lisp_malloc(len + 1);
memcpy(new_str, str, len + 1);
return new_str;
}
LispVal *make_lisp_string(const char *data, size_t length, bool take,
bool is_static) {
LispString *self = lisp_malloc(sizeof(LispString));
@ -136,7 +145,9 @@ LispVal *make_lisp_string(const char *data, size_t length, bool take,
if (take) {
self->data = (char *) data;
} else {
self->data = lisp_strdup(data);
self->data = lisp_malloc(length + 1);
memcpy(self->data, data, length);
self->data[length] = '\0';
}
self->length = length;
self->is_static = is_static;
@ -280,8 +291,15 @@ static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
} else if (self->eq_fn == Qstrings_equal) {
return !NILP(Fstrings_equal(v1, v2));
} else {
// TODO call the function
return false;
LispVal *eq_obj;
LispVal *args = make_list(2, v1, v2);
WITH_CLEANUP(args, {
eq_obj = lisp_ref(Ffuncall(self->eq_fn, args)); //
});
lisp_ref(eq_obj);
bool result = !NILP(eq_obj);
lisp_unref(eq_obj);
return result;
}
}
@ -289,14 +307,23 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
if (NILP(self->hash_fn)) {
return (uint64_t) key;
} else if (self->hash_fn == Qhash_string) {
// Make obarray lookups faster
// Make obarray and lexenv lookups faster
LispVal *hash_obj = Fhash_string(key);
uint64_t hash = ((LispInteger *) hash_obj)->value;
UNREF_INPLACE(hash_obj);
return hash;
} else {
// TODO call the hash function
return 0;
LispVal *hash_obj;
LispVal *args = make_list(1, key);
WITH_CLEANUP(args, {
hash_obj = Ffuncall(self->hash_fn, args); //
});
uint64_t hash;
WITH_CLEANUP(hash_obj, {
CHECK_TYPE(TYPE_INTEGER, hash_obj);
hash = ((LispInteger *) hash_obj)->value;
});
return hash;
}
}
@ -440,35 +467,424 @@ DEFUN(settail, "settail", (LispVal * pair, LispVal *tail)) {
return Qnil;
}
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
if (!SYMBOLP(signal)) {
printf("Attempt to throw non-symbol value!\n");
} else {
LispSymbol *sym = (LispSymbol *) signal;
printf("Throw %*s! Data: ", (int) sym->name->length, sym->name->data);
debug_dump(stdout, rest, true);
size_t list_length(LispVal *obj) {
if (NILP(obj)) {
return 0;
}
return Qnil;
CHECK_TYPE(TYPE_PAIR, obj);
size_t length = 0;
LispPair *tortise = (LispPair *) obj;
LispPair *hare = (LispPair *) tortise->tail;
while (!NILP(tortise)) {
if (!LISTP(LISPVAL(tortise))) {
break;
} else if (tortise == hare) {
Fthrow(Qcircular_error, Qnil);
}
++length;
tortise = (LispPair *) tortise->tail;
if (PAIRP(hare)) {
if (PAIRP(((LispPair *) hare)->tail)) {
hare = (LispPair *) ((LispPair *) hare->tail)->tail;
} else if (NILP(((LispPair *) hare)->tail)) {
hare = (LispPair *) Qnil;
}
}
}
return length;
}
StackFrame *the_stack = NULL;
DEF_STATIC_SYMBOL(toplevel, "toplevel");
DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv");
void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
StackFrame *frame = lisp_malloc(sizeof(StackFrame));
frame->name = lisp_ref(name);
frame->hidden = false;
frame->detail = lisp_ref(detail);
frame->lexenv = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
if (inherit && the_stack) {
Fputhash(LISPVAL(frame->lexenv), Qparent_lexenv,
LISPVAL(the_stack->lexenv));
}
frame->enable_handlers = true;
frame->handlers = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
frame->unwind_forms = Qnil;
frame->cleanup_handlers = NULL;
frame->next = the_stack;
the_stack = frame;
}
void stack_leave(void) {
StackFrame *frame = the_stack;
the_stack = the_stack->next;
lisp_unref(frame->name);
lisp_unref(frame->detail);
lisp_unref(frame->lexenv);
lisp_unref(frame->handlers);
FOREACH(elt, frame->unwind_forms) {
WITH_PUSH_FRAME(Qnil, Qnil, false, {
IGNORE_REF(Feval(elt)); //
});
}
lisp_unref(frame->unwind_forms);
while (frame->cleanup_handlers) {
frame->cleanup_handlers->fun(frame->cleanup_handlers->data);
struct CleanupHandlerEntry *next = frame->cleanup_handlers->next;
lisp_free(frame->cleanup_handlers);
frame->cleanup_handlers = next;
}
lisp_free(frame);
}
void *register_cleanup(lisp_cleanup_func_t fun, void *data) {
struct CleanupHandlerEntry *entry =
lisp_malloc(sizeof(struct CleanupHandlerEntry));
entry->fun = fun;
entry->data = data;
entry->next = the_stack->cleanup_handlers;
the_stack->cleanup_handlers = entry;
return entry;
}
void cancel_cleanup(void *handle) {
struct CleanupHandlerEntry *entry = the_stack->cleanup_handlers;
if (entry == handle) {
the_stack->cleanup_handlers = entry->next;
free(entry);
} else {
while (entry) {
if (entry->next == handle) {
struct CleanupHandlerEntry *to_free = entry->next;
entry->next = entry->next->next;
free(to_free);
break;
}
entry = entry->next;
}
}
}
DEFUN(backtrace, "backtrace", ()) {
LispVal *head = Qnil;
LispVal *end;
for (StackFrame *frame = the_stack; frame; frame = frame->next) {
if (frame->hidden) {
continue;
}
if (NILP(head)) {
head = Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
end = head;
} else {
LispVal *new_end =
Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
Fsettail(end, new_end);
end = new_end;
}
}
return head;
}
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
CHECK_TYPE(TYPE_SYMBOL, signal);
LispVal *backtrace = Fbacktrace();
for (; the_stack; stack_leave()) {
if (!the_stack->enable_handlers) {
continue;
}
LispVal *handler =
Fgethash(LISPVAL(the_stack->handlers), signal, Qunbound);
if (handler == Qunbound) {
// handler for all exceptions
handler = Fgethash(LISPVAL(the_stack->handlers), Qt, Qunbound);
}
if (handler != Qunbound) {
the_stack->enable_handlers = false;
LispVal *var = Fhead(handler);
LispVal *form = Ftail(handler);
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
if (!NILP(var)) {
// TODO make sure this isn't constant
Fputhash(the_stack->lexenv, var,
make_list(2, Fpair(signal, rest), backtrace));
}
WITH_CLEANUP(backtrace, {
IGNORE_REF(Feval(form)); //
});
});
longjmp(the_stack->start, 1); // return a nonzero value
}
}
// we never used it, so drop it
lisp_unref(backtrace);
fprintf(stderr,
"ERROR: An exception has propogated past the top of the stack!\n");
fprintf(stderr, "Type: ");
debug_dump(stderr, signal, true);
fprintf(stderr, "Args: ");
debug_dump(stderr, rest, true);
fprintf(stderr, "Lisp will now exit...");
abort();
}
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error");
DEF_STATIC_SYMBOL(void_function_error, "void-function-error");
DEF_STATIC_SYMBOL(circular_error, "circular-error");
LispVal *Vobarray = Qnil;
void lisp_init() {
Vobarray = lisp_ref(make_lisp_hashtable(Qstrings_equal, Qhash_string));
#define REGISTER_SYMBOL(fn) \
Fputhash(Vobarray, LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn)
REGISTER_SYMBOL(nil);
REGISTER_SYMBOL(t);
// TODO fill in the other fields
REGISTER_SYMBOL(pair);
REGISTER_SYMBOL(head);
REGISTER_SYMBOL(tail);
REGISTER_SYMBOL(quote);
REGISTER_SYMBOL(exit);
#undef REGISTER_SYMBOL
}
void lisp_shutdown() {
UNREF_INPLACE(Vobarray);
}
static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
while (HASHTABLEP(lexenv)) {
LispVal *value = Fgethash(lexenv, key, Qunbound);
if (value != Qunbound) {
return value;
}
lexenv = Fgethash(lexenv, Qparent_lexenv, Qunbound);
}
return Qunbound;
}
static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
if (!NILP(lexenv)) {
LispVal *local = find_in_lexenv(lexenv, key);
if (local != Qunbound) {
return local;
}
}
LispVal *sym_val = Fsymbol_value(key);
if (sym_val != Qunbound) {
return sym_val;
}
Fthrow(Qvoid_variable_error, make_list(1, key));
}
DEFUN(symbol_function, "symbol-function",
(LispVal * symbol, LispVal *resolve)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (NILP(resolve)) {
LispVal *fn = ((LispSymbol *) symbol)->function;
return fn == Qunbound ? Qnil : fn;
}
while (SYMBOLP(symbol) && symbol != Qunbound) {
symbol = ((LispSymbol *) symbol)->function;
}
return symbol;
}
DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return ((LispSymbol *) symbol)->value;
}
static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
LispVal *final_args = Qnil;
void *cl_handle = register_cleanup(
(lisp_cleanup_func_t) &lisp_unref_double_ptr, &final_args);
LispVal *end;
FOREACH(elt, args) {
if (NILP(final_args)) {
final_args = Fpair(Feval_in_env(elt, lexenv), Qnil);
end = final_args;
} else {
LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil);
Fsettail(end, new_end);
end = new_end;
}
}
cancel_cleanup(cl_handle);
return final_args;
}
static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) {
// TODO actually implement this
size_t count = list_length(args);
switch (count) {
case 0:
return ((LispVal * (*) ()) func->builtin)();
case 1:
return ((LispVal * (*) (LispVal * val)) func->builtin)(Fhead(args));
case 2:
return ((LispVal * (*) (LispVal * val1, LispVal * val2))
func->builtin)(Fhead(args), Fhead(Ftail(args)));
case 3:
return ((LispVal * (*) (LispVal * val1, LispVal * val2, LispVal * val3))
func->builtin)(Fhead(args), Fhead(Ftail(args)),
Fhead(Ftail(Ftail(args))));
/* case 4: */
/* return func->builtin(HEAD(args)); */
/* case 5: */
/* return func->builtin(HEAD(args)); */
/* case 6: */
/* return func->builtin(HEAD(args)); */
default:
return ((LispVal * (*) (LispVal * val)) func->builtin)(args);
}
}
static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
LispVal *args) {
// TODO do this
return Qnil;
}
static void check_args_for_function(LispFunction *fun, LispVal *args) {}
static LispVal *call_function(LispVal *func, LispVal *args,
LispVal *args_lexenv, bool eval_args) {
LispFunction *fobj;
if (FUNCTIONP(func)) {
fobj = (LispFunction *) func;
} else {
fobj = (LispFunction *) Fsymbol_function(func, Qt);
}
if (LISPVAL(fobj) == Qunbound) {
Fthrow(Qvoid_function_error, make_list(1, func));
}
CHECK_TYPE(TYPE_FUNCTION, fobj);
if (!fobj->is_macro && eval_args) {
args = eval_function_args(args, args_lexenv);
}
lisp_ref(args);
LispVal *retval = Qnil;
WITH_PUSH_FRAME(func, args, false, {
void *cl_handle = register_cleanup(
(lisp_cleanup_func_t) &lisp_unref_double_ptr, &args);
check_args_for_function(fobj, args);
if (fobj->is_builtin) {
retval = call_builtin(func, fobj, args);
} else {
retval = call_lisp_function(func, fobj, args);
}
cancel_cleanup(cl_handle);
})
lisp_unref(args);
return retval;
}
DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) {
switch (TYPEOF(form)) {
case TYPE_STRING:
case TYPE_FUNCTION:
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_HASHTABLE:
// the above all are self-evaluating
return form;
case TYPE_SYMBOL:
return symbol_value_in_lexenv(lexenv, form);
case TYPE_VECTOR: {
LispVector *vec = (LispVector *) form;
LispVal **elts = lisp_malloc(sizeof(LispVal *) * vec->length);
for (size_t i = 0; i < vec->length; ++i) {
elts[i] = lisp_ref(Feval_in_env(vec->data[i], lexenv));
}
return make_lisp_vector(elts, vec->length);
}
case TYPE_PAIR: {
LispPair *pair = (LispPair *) form;
return call_function(pair->head, pair->tail, lexenv, true);
}
default:
abort();
}
}
DEFUN(eval, "eval", (LispVal * form)) {
return Feval_in_env(form, LISPVAL(the_stack->lexenv));
}
DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) {
return call_function(function, rest, Qnil, false);
}
DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
LispVal *args = Qnil;
LispVal *end;
while (!NILP(rest) && !NILP(((LispPair *) rest)->tail)) {
if (NILP(args)) {
args = Fpair(((LispPair *) rest)->head, Qnil);
end = args;
} else {
LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);
Fsettail(end, new_end);
end = new_end;
}
rest = ((LispPair *) rest)->tail;
}
if (LISTP(((LispPair *) rest)->head)) {
Fsettail(end, ((LispPair *) rest)->head);
} else {
LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);
Fsettail(end, new_end);
end = new_end;
}
lisp_ref(args);
void *cl_handle =
register_cleanup((lisp_cleanup_func_t) &lisp_unref_double_ptr, &args);
LispVal *retval = Ffuncall(function, args);
cancel_cleanup(cl_handle);
lisp_unref(args);
return retval;
}
DEFUN(head, "head", (LispVal * list)) {
if (NILP(list)) {
return Qnil;
}
CHECK_TYPE(TYPE_PAIR, list);
return ((LispPair *) list)->head;
}
DEFUN(tail, "tail", (LispVal * list)) {
if (NILP(list)) {
return Qnil;
}
CHECK_TYPE(TYPE_PAIR, list);
return ((LispPair *) list)->tail;
}
DEFUN(exit, "exit", (LispVal * code)) {
if (!NILP(code) && !INTEGERP(code)) {
Fthrow(Qtype_error, Qnil);
}
Fthrow(Qshutdown_signal, make_list(1, code));
}
DEFMACRO(quote, "'", (LispVal * form)) {
return form;
}
static void debug_dump_real(FILE *stream, void *obj, bool first) {
switch (TYPEOF(obj)) {
case TYPE_NULL:
fprintf(stream, "nil");
break;
case TYPE_STRING: {
LispString *str = (LispString *) obj;
// TODO actually quote
@ -499,7 +915,7 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
}
} break;
case TYPE_INTEGER:
fprintf(stream, "%jd", ((LispInteger *) obj)->value);
fprintf(stream, "%jd", (intmax_t) ((LispInteger *) obj)->value);
break;
case TYPE_FLOAT:
fprintf(stream, "%Lf", ((LispFloat *) obj)->value);

161
src/lisp.h
View File

@ -1,12 +1,14 @@
#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) \
@ -16,7 +18,6 @@
#endif
typedef enum {
TYPE_NULL = 0,
TYPE_STRING,
TYPE_SYMBOL,
TYPE_PAIR,
@ -61,6 +62,7 @@ typedef struct {
LispVal *plist;
LispVal *function;
LispVal *value;
bool is_constant;
} LispSymbol;
typedef struct {
@ -73,7 +75,7 @@ typedef struct {
typedef struct {
LISP_OBJECT_HEADER;
intmax_t value;
int64_t value;
} LispInteger;
typedef struct {
@ -89,18 +91,25 @@ typedef struct {
size_t length;
} LispVector;
typedef LispVal *(*lisp_builtin_t)();
typedef struct {
LISP_OBJECT_HEADER;
LispVal *doc;
LispVal *args;
bool is_builtin;
bool is_macro;
size_t n_req;
size_t n_opt;
size_t n_kw;
LispVal **kwargs;
bool has_rest;
union {
void *builtin;
LispVal *body;
lisp_builtin_t builtin;
};
LispVal *lexenv;
} LispFunction;
struct HashtableBucket {
@ -125,7 +134,7 @@ typedef struct {
LispVal *hash_fn;
} LispHashtable;
#define NILP(v) (TYPEOF(v) == TYPE_NULL)
#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)
@ -137,6 +146,14 @@ typedef struct {
#define ATOM(v) (TYPEOF(v) != TYPE_PAIR)
extern LispSymbol _Qnil;
extern LispSymbol _Qunbound;
extern LispSymbol _Qt;
#define Qnil (LISPVAL(&_Qnil))
#define Qunbound (LISPVAL(&_Qunbound))
#define Qt (LISPVAL(&_Qt))
inline static bool LISTP(LispVal *v) {
return NILP(v) || PAIRP(v);
}
@ -145,15 +162,6 @@ inline static bool NUMBERP(LispVal *v) {
return INTEGERP(v) || FLOATP(v);
}
extern LispVal _Qnil;
extern LispSymbol _Qunbound;
extern LispSymbol _Qt;
#define Qnil (&_Qnil)
#define Qunbound (LISPVAL(&_Qunbound))
#define Qt (LISPVAL(&_Qt))
extern LispVal *Qquote;
extern LispVal *Qbackquote;
extern LispVal *Qcomma;
@ -176,13 +184,13 @@ extern LispVal *Qcomma;
.plist = Qnil, \
.function = Qunbound, \
.value = Qunbound, \
.is_constant = false, \
}; \
LispVal *Q##c_name = LISPVAL(&_Q##c_name);
void *lisp_malloc(size_t size);
void *lisp_realloc(void *old_ptr, size_t size);
#define lisp_free free
char *lisp_strdup(const char *str);
inline static void *lisp_ref(void *val) {
if (!STATICP(val)) {
@ -214,6 +222,10 @@ inline static void *lisp_unref(void *val) {
{ \
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)))
LispVal *make_lisp_string(const char *data, size_t length, bool take,
bool is_static);
@ -228,29 +240,36 @@ LispVal *make_lisp_vector(LispVal **data, size_t length);
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
#define DECLARE_FUNCTION(c_name, args) \
extern LispVal *Q##c_name; \
LispVal *F##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 DEFUN(c_name, lisp_name, c_args) \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
static LispFunction _Q##c_name##_function = { \
.type = TYPE_FUNCTION, \
.ref_count = -1, \
.doc = Qnil, \
.args = Qnil, \
.is_builtin = true, \
.builtin = &F##c_name, \
}; \
static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \
.ref_count = -1, \
.name = &_Q##c_name##_name, \
.plist = Qnil, \
.function = LISPVAL(&_Q##c_name##_function), \
}; \
LispVal *Q##c_name = (LispVal *) &_Q##c_name; \
#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, \
.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)
DECLARE_FUNCTION(type_of, (LispVal * obj));
DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail));
@ -285,6 +304,7 @@ LispVal *intern(const char *name, size_t length, bool take);
DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head));
DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail));
size_t list_length(LispVal *obj);
static inline LispVal *make_list(int len, ...) {
LispVal *list = Qnil;
LispVal *end;
@ -304,22 +324,87 @@ static inline LispVal *make_list(int len, ...) {
va_end(args);
return list;
}
#define FOREACH(var, list) \
for (LispVal *__foreach_cur = list, *var = Fhead(list); \
!NILP(__foreach_cur); \
__foreach_cur = Ftail(__foreach_cur), var = Fhead(__foreach_cur))
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;
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 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 *Qvoid_variable_error;
extern LispVal *Qvoid_function_error;
extern LispVal *Qcircular_error;
#define CHECK_TYPE(type, val) \
if (TYPEOF(val) != type) { \
Fthrow(Qtype_error, Qnil); \
return Qnil; \
}
extern LispVal *Vobarray;
void lisp_init(void);
void lisp_shutdown(void);
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));
void debug_dump(FILE *stream, void *obj, bool newline);
void debug_print_hashtable(FILE *stream, LispVal *table);

80
src/main.c
View File

@ -1,18 +1,84 @@
#include "lisp.h"
#include "read.h"
#include <string.h>
static int exit_status = 0;
LispVal *Ftoplevel_exit_handler(LispVal *except);
static LispFunction _Ftoplevel_exit_handler_function = {
.type = TYPE_FUNCTION,
.ref_count = -1,
.is_builtin = 1,
.is_macro = 0,
.builtin = &Ftoplevel_exit_handler,
.lexenv = Qnil,
};
#define Ftoplevel_exit_handler_function \
LISPVAL(&_Ftoplevel_exit_handler_function)
LispVal *Ftoplevel_exit_handler(LispVal *except) {
LispVal *detail = Ftail(Fhead(except));
if (NILP(detail) || NILP(Fhead(detail))) {
exit_status = 0;
} else if (!INTEGERP(Fhead(detail))) {
exit_status = 1;
} else {
exit_status = ((LispInteger *) Fhead(detail))->value;
}
return Qnil;
}
LispVal *Ftoplevel_error_handler(LispVal *except);
static LispFunction _Ftoplevel_error_handler_function = {
.type = TYPE_FUNCTION,
.ref_count = -1,
.is_builtin = 1,
.is_macro = 0,
.builtin = &Ftoplevel_error_handler,
.lexenv = Qnil,
};
#define Ftoplevel_error_handler_function \
LISPVAL(&_Ftoplevel_error_handler_function)
LispVal *Ftoplevel_error_handler(LispVal *except) {
LispVal *type = Fhead(Fhead(except));
LispVal *detail = Ftail(Fhead(except));
LispVal *backtrace = Fhead(Ftail(except));
fprintf(stderr, "Caught signal of type ");
debug_dump(stderr, type, true);
if (!NILP(detail)) {
fprintf(stderr, "Details: ");
debug_dump(stderr, detail, true);
}
fprintf(stderr, "\nBacktrace (toplevel comes last):\n");
FOREACH(frame, backtrace) {
fprintf(stderr, " ");
debug_dump(stderr, frame, true);
}
exit_status = 1;
return Qnil;
}
int main(int argc, const char **argv) {
lisp_init();
char buffer[] = "1";
char buffer[] = "(t)";
LispVal *tv;
size_t count = read_from_buffer(buffer, sizeof(buffer) - 1, &tv);
read_from_buffer(buffer, sizeof(buffer) - 1, &tv);
lisp_ref(tv);
printf("Read %zu chars\n", count);
printf("Type: %s\n", OBJ_TYPE_NAME(tv));
debug_dump(stdout, tv, true);
WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
the_stack->hidden = true;
LispVal *err_var = INTERN_STATIC("err-var");
Fputhash(
the_stack->handlers, Qt,
// simply call the above function
make_list(3, err_var, Ftoplevel_error_handler_function, err_var));
Fputhash(
the_stack->handlers, Qshutdown_signal,
// simply call the above function
make_list(3, err_var, Ftoplevel_exit_handler_function, err_var));
LispVal *out = Feval(tv);
lisp_ref(out);
debug_dump(stdout, out, 1);
lisp_unref(out);
})
UNREF_INPLACE(tv);
lisp_shutdown();
return 0;
return exit_status;
}