diff --git a/src/kernel.el b/src/kernel.el new file mode 100644 index 0000000..7fd739d --- /dev/null +++ b/src/kernel.el @@ -0,0 +1,125 @@ +;; -*- mode: lisp-data -*- + +(fset 'null 'not) +(defun list (&rest r) r) + +(fset 'first 'head) +(defun second (list) + (head (tail list))) +(defun third (list) + (head (tail (tail list)))) +(defun fourth (list) + (head (tail (tail (tail list))))) +(defun fifth (list) + (head (tail(tail (tail (tail list)))))) +(defun sixth (list) + (head (tial (tail (tail (tail (tail list))))))) +(defun seventh (list) + (head (tail (tail (tail (tail (tail (tail list)))))))) +(defun eight (list) + (head (tail (tail (tail (tail (tail (tail (tail list))))))))) +(defun ninth (list) + (head (tail (tail (tail (tail (tail (tail (tail (tail list)))))))))) +(defun tenth (list) + (head (tail (tail (tail (tail (tail (tail (tail (tail (tail list))))))))))) + +(defmacro dolist (vars &rest body) + (funcall + (lambda (tail-var) + (list 'progn + (list 'setq tail-var (second vars)) + (list 'while tail-var + (list 'funcall (apply 'list 'lambda (list (first vars)) body) + (list 'head tail-var)) + (list 'setq tail-var (list 'tail tail-var))))) + (make-symbol "tail"))) + +(defun maphead (func list) + (funcall + (lambda (&opt start end) + (dolist (elt list) + (setq elt (funcall func elt)) + (if (not start) + (setq start (pair elt nil) + end start) + (settail end (pair elt nil)) + (setq end (tail end)))) + start))) + +(defun reverse (list) + (funcall + (lambda (&opt out) + (dolist (elt list) + (setq out (pair elt out))) + out))) + +(defun < (n1 n2) + (not (or (> n1 n2) (= n1 n2)))) + +(defun <= (n1 n2) + (not (> n1 n2))) + +(defun >= (n1 n2) + (or (> n1 n2) (= n1 n2))) + +(defmacro let (bindings &rest body) + (funcall + (lambda (&opt vars vals) + (dolist (ent bindings) + (if (symbolp ent) + (setq vars (pair ent vars) + vals (pair nil vals)) + (if (and (listp ent) (or (= (list-length ent) 1) + (= (list-length ent) 2))) + (setq vars (pair (first ent) vars) + vals (pair (second ent) vals)) + (throw 'argument-error)))) + (apply 'list 'funcall (apply 'list 'lambda (reverse vars) body) + (reverse vals))))) + +(defun lasttail (list) + "Return the last pair in LIST." + (let (out) + (while list + (setq out list + list (tail list))) + out)) + +(defun internal-expand-single-cond (cond) + (if (tail cond) + (list 'if (head cond) + (apply 'list 'progn (tail cond))) + (let ((res-var (make-symbol "res"))) + (list 'let (list (list res-var (head cond))) + (list 'if res-var res-var))))) + +(defmacro cond (&rest conds) + (let (out last-if) + (dolist (cond conds) + (if (not out) + (setq out (internal-expand-single-cond cond) + last-if out) + (let ((new-if (internal-expand-single-cond cond))) + (settail (lasttail last-if) (list new-if)) + (setq last-if new-if)))) + out)) + +(defun internal-expand-\` (form) + (cond + ((and (listp form) (eq (head form) '\,)) + (list (eval (second form)))) + ((and (listp form) (eq (head form) '\,@)) + (eval (second form))) + ((pairp form) + (let (out end) + (dolist (arg form) + (if (not out) + (setq out (internal-expand-\` arg) + end (lasttail out)) + (settail end (internal-expand-\` arg)) + (setq end (lasttail end)))) + (list out))) + (t (list form)))) + +(defmacro \` (form) + (list '\' (head (internal-expand-\` form)))) diff --git a/src/lisp.c b/src/lisp.c index 1cfc595..5bff946 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -378,7 +378,7 @@ LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body, self->oargs = Qnil; self->rest_arg = Qnil; self->kwargs = Qnil; - void *cl = register_cleanup(&free_double_ptr, &self); + void *cl = register_cleanup(&lisp_free, self); set_function_args(self, args); cancel_cleanup(cl); @@ -465,8 +465,8 @@ static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) { return !NILP(Fstrings_equal(v1, v2)); } else { LispVal *eq_obj; - LispVal *args = const_list(2, v1, v2); - WITH_CLEANUP(args, { + LispVal *args = const_list(true, 2, v1, v2); + WITH_CLEANUP_DOUBLE_PTR(args, { eq_obj = Ffuncall(self->eq_fn, args); // }); bool result = !NILP(eq_obj); @@ -486,12 +486,12 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) { return hash; } else { LispVal *hash_obj; - LispVal *args = const_list(1, key); - WITH_CLEANUP(args, { + LispVal *args = const_list(true, 1, key); + WITH_CLEANUP_DOUBLE_PTR(args, { hash_obj = Ffuncall(self->hash_fn, args); // }); uint64_t hash; - WITH_CLEANUP(hash_obj, { + WITH_CLEANUP_DOUBLE_PTR(hash_obj, { CHECK_TYPE(TYPE_INTEGER, hash_obj); hash = ((LispInteger *) hash_obj)->value; }); @@ -684,16 +684,16 @@ DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv"); void stack_enter(LispVal *name, LispVal *detail, bool inherit) { StackFrame *frame = lisp_malloc(sizeof(StackFrame)); - frame->name = refcount_ref(name); + frame->name = (LispSymbol *) name; frame->hidden = false; - frame->detail = refcount_ref(detail); - frame->lexenv = refcount_ref(make_lisp_hashtable(Qnil, Qnil)); + frame->detail = detail; + frame->lexenv = make_lisp_hashtable(Qnil, Qnil); if (inherit && the_stack) { puthash(LISPVAL(frame->lexenv), Qparent_lexenv, LISPVAL(the_stack->lexenv)); } frame->enable_handlers = true; - frame->handlers = refcount_ref(make_lisp_hashtable(Qnil, Qnil)); + frame->handlers = make_lisp_hashtable(Qnil, Qnil); frame->unwind_forms = Qnil; frame->cleanup_handlers = NULL; @@ -710,6 +710,7 @@ void stack_leave(void) { refcount_unref(frame->handlers); FOREACH(elt, frame->unwind_forms) { WITH_PUSH_FRAME(Qnil, Qnil, false, { + the_stack->hidden = true; refcount_unref(Feval(elt)); // }); } @@ -786,6 +787,7 @@ DEFUN(backtrace, "backtrace", (void) ) { Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil); refcount_unref(HEAD(new_end)); Fsettail(end, new_end); + refcount_unref(new_end); end = new_end; } } @@ -796,7 +798,8 @@ DEFUN(backtrace, "backtrace", (void) ) { #pragma GCC diagnostic ignored "-Winfinite-recursion" DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { CHECK_TYPE(TYPE_SYMBOL, signal); - LispVal *error_arg = const_list(2, Fpair(signal, rest), Fbacktrace()); + LispVal *error_arg = + const_list(false, 2, Fpair(signal, rest), Fbacktrace()); for (; the_stack; stack_leave()) { if (!the_stack->enable_handlers) { continue; @@ -809,30 +812,30 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { } if (handler != Qunbound) { the_stack->enable_handlers = false; - LispVal *var = Fhead(handler); - LispVal *form = Ftail(handler); + LispVal *var = HEAD(handler); + LispVal *form = TAIL(handler); WITH_PUSH_FRAME(Qnil, Qnil, true, { the_stack->hidden = true; if (!NILP(var)) { // TODO make sure this isn't constant puthash(the_stack->lexenv, var, error_arg); } - WITH_CLEANUP(error_arg, { + WITH_CLEANUP_DOUBLE_PTR(error_arg, { refcount_unref(Feval(form)); // }); }); longjmp(the_stack->start, 1); // return a nonzero value } } - // we never used it, so drop it - refcount_unref(error_arg); fprintf(stderr, - "ERROR: An exception has propogated past the top of the stack!\n"); + "ERROR: An exception has propagated 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..."); + // we never used it, so drop it + refcount_unref(error_arg); abort(); } #pragma GCC diagnostic pop @@ -1103,7 +1106,7 @@ static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) { while (HASHTABLEP(lexenv)) { LispVal *value = gethash(lexenv, key, Qunbound); if (value != Qunbound) { - return value; + return refcount_ref(value); } lexenv = gethash(lexenv, Qparent_lexenv, Qunbound); } @@ -1122,7 +1125,7 @@ static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) { return sym_val; } // TODO free args (not just this call, all calls to Fthrow) - Fthrow(Qvoid_variable_error, const_list(1, key)); + Fthrow(Qvoid_variable_error, const_list(true, 1, key)); } static void breakpoint(int64_t id) {} @@ -1157,22 +1160,26 @@ DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) { static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) { LispVal *final_args = Qnil; - void *cl_handle = - register_cleanup((lisp_cleanup_func_t) &unref_double_ptr, &final_args); - LispVal *end; - FOREACH(elt, args) { - if (NILP(final_args)) { - final_args = Fpair(Feval_in_env(elt, lexenv), Qnil); - refcount_unref(HEAD(final_args)); - end = final_args; - } else { - LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil); - refcount_unref(HEAD(new_end)); - Fsettail(end, new_end); - end = new_end; + WITH_PUSH_FRAME(Qnil, Qnil, true, { + the_stack->hidden = true; + void *cl_handle = register_cleanup( + (lisp_cleanup_func_t) &unref_double_ptr, &final_args); + LispVal *end; + FOREACH(elt, args) { + if (NILP(final_args)) { + final_args = Fpair(Feval_in_env(elt, lexenv), Qnil); + refcount_unref(HEAD(final_args)); + end = final_args; + } else { + LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil); + refcount_unref(HEAD(new_end)); + Fsettail(end, new_end); + refcount_unref(new_end); + end = new_end; + } } - } - cancel_cleanup(cl_handle); + cancel_cleanup(cl_handle); + }); return final_args; } @@ -1200,7 +1207,7 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func, if (vec[oad->index]) { goto multikey; } - args = Ftail(args); + args = TAIL(args); if (NILP(args)) { goto key_no_val; } @@ -1224,7 +1231,7 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func, goto too_few; } if (!NILP(func->rest_arg)) { - vec[raw_count - 1] = refcount_ref(rest); + vec[raw_count - 1] = rest; } for (size_t i = 0; i < raw_count; ++i) { if (!vec[i]) { @@ -1420,7 +1427,7 @@ static LispVal *call_lisp_function(LispVal *name, LispFunction *func, } LispVal *expansion = Fprogn(func->body); LispVal *retval = Qnil; - WITH_CLEANUP(expansion, { + WITH_CLEANUP_DOUBLE_PTR(expansion, { // eval in the outer lexenv retval = Feval_in_env(expansion, args_lexenv); }); @@ -1441,9 +1448,9 @@ static LispVal *call_function(LispVal *func, LispVal *args, } else { Fthrow(Qinvalid_function_error, Fpair(func, Qnil)); } - void *cl_handle = register_cleanup(unref_double_ptr, &fobj); + void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj); if (LISPVAL(fobj) == Qunbound) { - Fthrow(Qvoid_function_error, const_list(1, func)); + Fthrow(Qvoid_function_error, const_list(true, 1, func)); } else if (!FUNCTIONP(fobj)) { Fthrow(Qinvalid_function_error, Fpair(LISPVAL(fobj), Qnil)); } else if (!allow_macro && fobj->is_macro) { @@ -1454,18 +1461,18 @@ static LispVal *call_function(LispVal *func, LispVal *args, } LispVal *retval = Qnil; // builtin macros inherit their parents lexenv - WITH_PUSH_FRAME(func, args, false, { - if (fobj->is_macro && fobj->is_builtin) { - puthash(the_stack->lexenv, Qparent_lexenv, args_lexenv); - } - void *cl_handle = - register_cleanup((lisp_cleanup_func_t) &unref_double_ptr, &args); - if (fobj->is_builtin) { - retval = call_builtin(func, fobj, args); - } else { - retval = call_lisp_function(func, fobj, args, args_lexenv); - } - cancel_cleanup(cl_handle); + refcount_ref(args); + WITH_CLEANUP(args, { + WITH_PUSH_FRAME(func, args, false, { + if (fobj->is_macro && fobj->is_builtin) { + puthash(the_stack->lexenv, Qparent_lexenv, args_lexenv); + } + if (fobj->is_builtin) { + retval = call_builtin(func, fobj, args); + } else { + retval = call_lisp_function(func, fobj, args, args_lexenv); + } + }); }); cancel_cleanup(cl_handle); return retval; @@ -1522,7 +1529,7 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) { return refcount_ref(form); } LispVal *expansion = Qnil; - WITH_CLEANUP(fobj, { + WITH_CLEANUP_DOUBLE_PTR(fobj, { WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, { puthash(the_stack->lexenv, Qparent_lexenv, fobj->lexenv); process_lisp_args(Fhead(form), fobj, Ftail(form), @@ -1554,7 +1561,7 @@ DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { if (LISTP(HEAD(rest))) { // ensure the list is not circular refcount_ref(args); - WITH_CLEANUP(args, { + WITH_CLEANUP_DOUBLE_PTR(args, { list_length(Fhead(rest)); // }); if (NILP(args)) { @@ -1574,7 +1581,7 @@ DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { } } LispVal *retval; - WITH_CLEANUP(args, { + WITH_CLEANUP_DOUBLE_PTR(args, { retval = Ffuncall(function, args); // }); return retval; @@ -1592,7 +1599,7 @@ DEFUN(exit, "exit", (LispVal * code)) { if (!NILP(code) && !INTEGERP(code)) { Fthrow(Qtype_error, Qnil); } - Fthrow(Qshutdown_signal, const_list(1, code)); + Fthrow(Qshutdown_signal, const_list(true, 1, code)); } DEFMACRO(quote, "'", (LispVal * form)) { @@ -1696,7 +1703,7 @@ DEFUN(add, "+", (LispVal * args)) { LispVal *out = copy_number(Fhead(args)); FOREACH(arg, Ftail(args)) { LispVal *old_out = out; - WITH_CLEANUP(old_out, { + WITH_CLEANUP_DOUBLE_PTR(old_out, { ONE_MATH_OPERAION(+, out, out, arg); // }); } @@ -1710,7 +1717,7 @@ DEFUN(sub, "-", (LispVal * args)) { LispVal *out = copy_number(Fhead(args)); FOREACH(arg, Ftail(args)) { LispVal *old_out = out; - WITH_CLEANUP(old_out, { + WITH_CLEANUP_DOUBLE_PTR(old_out, { ONE_MATH_OPERAION(-, out, out, arg); // }); } @@ -1740,7 +1747,7 @@ DEFMACRO(setq, "setq", (LispVal * args)) { FOREACH_TAIL(tail, args) { CHECK_TYPE(TYPE_SYMBOL, HEAD(tail)); LispVal *name = HEAD(tail); - tail = HEAD(tail); + tail = TAIL(tail); retval = Feval(HEAD(tail)); set_symbol_in_lexenv(name, retval, the_stack->lexenv); } @@ -1879,7 +1886,7 @@ DEFMACRO(and, "and", (LispVal * rest)) { LispVal *retval = Qnil; FOREACH(cond, rest) { LispVal *nc; - WITH_CLEANUP(retval, { + WITH_CLEANUP_DOUBLE_PTR(retval, { nc = Feval(cond); // }); if (NILP(nc)) { diff --git a/src/lisp.h b/src/lisp.h index a823be9..67d2406 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -347,7 +347,7 @@ static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len) { 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, ...) { +static inline LispVal *const_list(bool do_ref, int len, ...) { LispVal *list = Qnil; LispVal *end; va_list args; @@ -363,6 +363,9 @@ static inline LispVal *const_list(int len, ...) { refcount_unref(new_end); end = new_end; } + if (!do_ref) { + refcount_unref(((LispPair *) end)->head); + } } va_end(args); return list; @@ -418,13 +421,16 @@ struct UnrefListData { void unref_free_list_double_ptr(void *ptr); void unref_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 \ - } \ +#define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \ + stack_enter(name, detail, inherit); \ + if (setjmp(the_stack->start) == 0) { \ + body \ + } \ stack_leave(); -#define WITH_CLEANUP(var, 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)); \ @@ -432,6 +438,14 @@ void cancel_cleanup(void *handle); 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); \ + } DECLARE_FUNCTION(backtrace, (void) ); noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest)); @@ -449,12 +463,13 @@ extern LispVal *Qinvalid_function_error; extern LispVal *Qno_applicable_method_error; LispVal *predicate_for_type(LispType type); -#define CHECK_TYPE(type, val) \ - if (TYPEOF(val) != type) { \ - LispVal *inner_list = const_list(1, predicate_for_type(type)); \ - LispVal *args = const_list(2, inner_list, Ftype_of(LISPVAL(val))); \ - refcount_unref(inner_list); \ - Fthrow(Qtype_error, args); \ +#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); \ } extern LispVal *Vobarray; diff --git a/src/main.c b/src/main.c index 4b6ce97..5743421 100644 --- a/src/main.c +++ b/src/main.c @@ -89,23 +89,21 @@ int main(int argc, const char **argv) { size_t pos = 0; WITH_PUSH_FRAME(Qtoplevel, Qnil, false, { the_stack->hidden = true; - /* LispVal *err_var = INTERN_STATIC("err-var"); */ - /* puthash( */ - /* the_stack->handlers, Qt, */ - /* // simply call the above function */ - /* const_list(3, err_var, Ftoplevel_error_handler_function, - * err_var)); */ - /* puthash( */ - /* the_stack->handlers, Qshutdown_signal, */ - /* // simply call the above function */ - /* const_list(3, err_var, Ftoplevel_exit_handler_function, - * err_var)); */ - /* LispVal *nil_nil = Fpair(Qnil, Qnil); */ - /* puthash(the_stack->handlers, Qeof_error, */ - /* // ignore */ - /* nil_nil); */ - /* refcount_unref(nil_nil); */ - /* refcount_unref(err_var); */ + LispVal *err_var = INTERN_STATIC("err-var"); + puthash(the_stack->handlers, Qt, + // simply call the above function + const_list(true, 3, err_var, Ftoplevel_error_handler_function, + err_var)); + puthash(the_stack->handlers, Qshutdown_signal, + // simply call the above function + const_list(true, 3, err_var, Ftoplevel_exit_handler_function, + err_var)); + LispVal *nil_nil = Fpair(Qnil, Qnil); + puthash(the_stack->handlers, Qeof_error, + // ignore + nil_nil); + refcount_unref(nil_nil); + refcount_unref(err_var); while (true) { LispVal *tv; WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, { diff --git a/src/read.c b/src/read.c index df85dab..e552ce2 100644 --- a/src/read.c +++ b/src/read.c @@ -49,10 +49,7 @@ static inline _Noreturn void _internal_read_error(struct ReadState *state, LispVal *line = make_lisp_integer(state->line); LispVal *col = make_lisp_integer(state->col); LispVal *ctx = make_lisp_string(state->head, len, false, false); - LispVal *args = const_list(4, line, col, ctx, desc); - refcount_unref(line); - refcount_unref(col); - refcount_unref(ctx); + LispVal *args = const_list(false, 4, line, col, ctx, refcount_ref(desc)); WITH_CLEANUP(args, { Fthrow(cause, args); // });