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);