diff --git a/src/lisp.c b/src/lisp.c index 902e971..354a1d7 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -6,7 +6,6 @@ #include 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); diff --git a/src/lisp.h b/src/lisp.h index 8e494e7..abd5c6b 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1,12 +1,14 @@ #ifndef INCLUDED_LISP_H #define INCLUDED_LISP_H +#include #include #include #include #include #include #include +#include #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); diff --git a/src/main.c b/src/main.c index aafd1d7..44eb0f1 100644 --- a/src/main.c +++ b/src/main.c @@ -1,18 +1,84 @@ #include "lisp.h" #include "read.h" -#include +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; }