diff --git a/src/kernel.sl b/src/kernel.sl index 05a8f1c..80e680a 100644 --- a/src/kernel.sl +++ b/src/kernel.sl @@ -85,23 +85,12 @@ (setq vars (pair (first ent) vars) vals (pair (second ent) vals)) (throw 'argument-error)))) - (apply 'list 'funcall (apply 'list 'lambda (reverse vars) body) + (apply 'list 'funcall (apply 'list 'lambda + (reverse vars) + '(declare (name nil)) + body) (reverse vals))))) -(defun plist-put (plist key value) - (let ((tail plist)) - (while (and tail (tail tail)) - (if (eq (head tail) key) - (sethead (tail tail) value)) - (setq tail (tail (tail tail)))))) - -(defun put (symbol key value) - (let ((cur (symbol-plist symbol))) - ())) - -(defun get (symbol key default) - ()) - (defun lasttail (list) "Return the last pair in LIST." (let (out) @@ -146,23 +135,6 @@ (pair pred (tail cond)))) conds))))) -(defun internal-expand-\` (form &opt (level 0)) - (tcase - (()))) - -(defmacro \` (form) - (internal-expand-\` form)) - -;; (println (macroexpand-1 '`(,@a))) - -(defmacro a (form) - (list 'b (ensure-list form))) - -(defmacro b (form) - (list 'c (ensure-list form))) - -(defmacro c (form) - (list 'd form)) - -;; (let ((a '(1 2 3))) -;; (println `(,a))) +(defmacro unwind-protect (form &rest unwind-forms) + (list 'condition-case form + (pair :finally unwind-forms))) diff --git a/src/lisp.c b/src/lisp.c index 41f7456..c0a1645 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -170,6 +170,8 @@ DEF_STATIC_SYMBOL(opt, "&opt"); DEF_STATIC_SYMBOL(key, "&key"); DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys"); DEF_STATIC_SYMBOL(rest, "&rest"); +DEF_STATIC_SYMBOL(declare, "declare"); +DEF_STATIC_SYMBOL(name, "name"); static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod, LispVal *found_args) { @@ -368,8 +370,8 @@ malformed: Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil)); } -LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body, - bool is_macro) { +LispVal *make_lisp_function(LispVal *name, LispVal *args, LispVal *lexenv, + LispVal *body, bool is_macro) { CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION); self->is_builtin = false; self->is_macro = is_macro; @@ -383,6 +385,7 @@ LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body, cancel_cleanup(cl); // do these after the potential throw + self->name = refcount_ref(name); self->lexenv = refcount_ref(lexenv); if (STRINGP(HEAD(body))) { self->doc = refcount_ref(HEAD(body)); @@ -679,23 +682,21 @@ size_t list_length(LispVal *obj) { } StackFrame *the_stack = NULL; +LispVal *stack_return = NULL; DEF_STATIC_SYMBOL(toplevel, "toplevel"); -DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv"); // DO NOT INTERN -DEF_STATIC_SYMBOL(return_signal, "return-signal"); // DO NOT INTERN void stack_enter(LispVal *name, LispVal *detail, bool inherit) { StackFrame *frame = lisp_malloc(sizeof(StackFrame)); frame->name = (LispSymbol *) name; - frame->hidden = false; + frame->hidden = true; frame->detail = detail; - frame->lexenv = make_lisp_hashtable(Qnil, Qnil); + frame->lexenv = Qnil; if (inherit && the_stack) { - puthash(LISPVAL(frame->lexenv), Qparent_lexenv, - LISPVAL(the_stack->lexenv)); + frame->lexenv = refcount_ref(the_stack->lexenv); } frame->enable_handlers = true; frame->handlers = make_lisp_hashtable(Qnil, Qnil); - frame->unwind_forms = Qnil; + frame->unwind_form = Qnil; frame->cleanup_handlers = NULL; frame->next = the_stack; @@ -709,20 +710,21 @@ void stack_leave(void) { refcount_unref(frame->detail); refcount_unref(frame->lexenv); refcount_unref(frame->handlers); - FOREACH(elt, frame->unwind_forms) { - WITH_PUSH_FRAME(Qnil, Qnil, false, { - the_stack->hidden = true; - refcount_unref(Feval(elt)); // - }); - } - refcount_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; } + LispVal *unwind_form = frame->unwind_form; + // steal the ref + frame->unwind_form = Qnil; lisp_free(frame); + if (!NILP(unwind_form)) { + WITH_CLEANUP(unwind_form, { + refcount_unref(Feval(unwind_form)); // + }) + } } void *register_cleanup(lisp_cleanup_func_t fun, void *data) { @@ -795,15 +797,20 @@ DEFUN(backtrace, "backtrace", (void) ) { return head; } +DEFUN(return_from, "return-from", (LispVal * name, LispVal *value)) { + // TODO actually write this + abort(); +} + #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Winfinite-recursion" DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { CHECK_TYPE(TYPE_SYMBOL, signal); LispVal *error_arg = const_list(false, 2, Fpair(signal, rest), Fbacktrace()); - for (; the_stack; stack_leave()) { + while (the_stack) { if (!the_stack->enable_handlers) { - continue; + goto up_frame; } LispVal *handler = gethash(LISPVAL(the_stack->handlers), signal, Qunbound); @@ -816,17 +823,31 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { 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); + push_to_lexenv(&the_stack->lexenv, var, error_arg); } - WITH_CLEANUP_DOUBLE_PTR(error_arg, { - refcount_unref(Feval(form)); // + WITH_CLEANUP(error_arg, { + stack_return = Feval(form); // }); }); - longjmp(the_stack->start, 1); // return a nonzero value + longjmp(the_stack->start, STACK_EXIT_THROW); } + up_frame: { + // steal the form so we can call it after we unwind (in case it + // throws) + LispVal *unwind_form = the_stack->unwind_form; + the_stack->unwind_form = Qnil; + stack_leave(); + if (!NILP(unwind_form)) { + void *cl_handler = + register_cleanup(&refcount_unref_as_callback, error_arg); + WITH_CLEANUP(unwind_form, { + refcount_unref(Feval(unwind_form)); // + }); + cancel_cleanup(cl_handler); + } + } } fprintf(stderr, "ERROR: An exception has propagated past the top of the stack!\n"); @@ -841,6 +862,8 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { } #pragma GCC diagnostic pop +DEF_STATIC_SYMBOL(success, ":success"); +DEF_STATIC_SYMBOL(finally, ":finally"); DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal"); DEF_STATIC_SYMBOL(type_error, "type-error"); DEF_STATIC_SYMBOL(read_error, "read-error"); @@ -852,6 +875,7 @@ DEF_STATIC_SYMBOL(malformed_lambda_list_error, "malformed-lambda-list-error"); DEF_STATIC_SYMBOL(argument_error, "argument-error"); DEF_STATIC_SYMBOL(invalid_function_error, "invalid-function-error"); DEF_STATIC_SYMBOL(no_applicable_method_error, "no-applicable-method-error"); +DEF_STATIC_SYMBOL(return_frame_error, "return-frame-error"); LispVal *predicate_for_type(LispType type) { switch (type) { @@ -913,6 +937,7 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) { return true; case TYPE_FUNCTION: { LispFunction *fn = obj; + *held = refcount_list_push(*held, fn->name); *held = refcount_list_push(*held, fn->args); *held = refcount_list_push(*held, fn->kwargs); *held = refcount_list_push(*held, fn->oargs); @@ -962,11 +987,11 @@ static void free_obj_callback(void *obj, void *ignored) { } lisp_free(tbl->data); } break; + case TYPE_FUNCTION: case TYPE_SYMBOL: case TYPE_PAIR: case TYPE_INTEGER: case TYPE_FLOAT: - case TYPE_FUNCTION: // no internal data to free break; default: @@ -993,9 +1018,13 @@ void lisp_init(void) { REGISTER_SYMBOL(allow_other_keys); REGISTER_SYMBOL(key); REGISTER_SYMBOL(rest); + REGISTER_SYMBOL(declare); + REGISTER_SYMBOL(name); REGISTER_SYMBOL(comma); REGISTER_SYMBOL(comma_at); REGISTER_SYMBOL(backquote); + REGISTER_SYMBOL(success); + REGISTER_SYMBOL(finally); REGISTER_SYMBOL(shutdown_signal); REGISTER_SYMBOL(type_error); REGISTER_SYMBOL(read_error); @@ -1007,11 +1036,10 @@ void lisp_init(void) { REGISTER_SYMBOL(argument_error); REGISTER_SYMBOL(invalid_function_error); REGISTER_SYMBOL(no_applicable_method_error); + REGISTER_SYMBOL(return_frame_error); refcount_init_static(Qtoplevel); - refcount_init_static(&_Qtoplevel_name); - refcount_init_static(Qparent_lexenv); - refcount_init_static(&_Qparent_lexenv_name); + refcount_init_static(&_Qtoplevel_symnamestr); REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing..."); REGISTER_FUNCTION(sethead, "(pair newval)", @@ -1106,7 +1134,14 @@ void lisp_init(void) { "Logical or (with short circuit evaluation.)"); REGISTER_FUNCTION(type_of, "(obj)", "Return the type of OBJ."); REGISTER_FUNCTION(function_docstr, "(func)", - "Return the documentation string of FUNC.") + "Return the documentation string of FUNC."); + REGISTER_FUNCTION(plist_get, "(plist key &opt def pred)", ""); + REGISTER_FUNCTION(plist_set, "(plist key value &opt pred)", ""); + REGISTER_FUNCTION(plist_rem, "(plist key &opt pred)", ""); + REGISTER_FUNCTION(return_from, "(name &opt value)", + "Return from the function named NAME and return VALUE."); + REGISTER_FUNCTION(intern, "(name)", ""); + REGISTER_FUNCTION(condition_case, "(form &rest handlers)", ""); } void lisp_shutdown(void) { @@ -1118,15 +1153,8 @@ void lisp_shutdown(void) { refcount_default_context = NULL; } -static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) { - while (HASHTABLEP(lexenv)) { - LispVal *value = gethash(lexenv, key, Qunbound); - if (value != Qunbound) { - return refcount_ref(value); - } - lexenv = gethash(lexenv, Qparent_lexenv, Qunbound); - } - return Qunbound; +static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) { + return Fplist_get(lexenv, key, Qunbound, Qnil); } static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) { @@ -1140,7 +1168,6 @@ static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) { if (sym_val != Qunbound) { return sym_val; } - // TODO free args (not just this call, all calls to Fthrow) Fthrow(Qvoid_variable_error, const_list(true, 1, key)); } @@ -1190,7 +1217,6 @@ DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) { static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) { LispVal *final_args = Qnil; 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; @@ -1285,7 +1311,11 @@ too_few: return NULL; } -static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) { +static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args, + LispVal *args_lexenv) { + if (func->is_macro) { + the_stack->lexenv = refcount_ref(args_lexenv); + } size_t nargs; LispVal **arg_vec = process_builtin_args(name, func, args, &nargs); struct UnrefListData cleanup_data = {.vals = arg_vec, .len = nargs}; @@ -1337,7 +1367,8 @@ static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) { } static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, - LispVal *lexenv) { + LispVal **lexenv) { + LispVal *added_kwds = make_lisp_hashtable(Qnil, Qnil); enum { REQ, OPT, KEY, REST } mode = REQ; LispVal *rargs = func->rargs; LispVal *oargs = func->oargs; @@ -1349,7 +1380,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, mode = OPT; continue; // skip increment } - puthash(lexenv, HEAD(rargs), arg); + push_to_lexenv(lexenv, HEAD(rargs), arg); rargs = TAIL(rargs); } break; case OPT: { @@ -1358,9 +1389,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, continue; // skip increment } struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs)); - puthash(lexenv, oad->name, arg); + push_to_lexenv(lexenv, oad->name, arg); if (!NILP(oad->pred_var)) { - puthash(lexenv, oad->pred_var, Qt); + push_to_lexenv(lexenv, oad->pred_var, Qt); } oargs = TAIL(oargs); } break; @@ -1383,9 +1414,10 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, goto missing_value; } LispVal *value = HEAD(args); - puthash(lexenv, oad->name, value); + puthash(added_kwds, oad->name, Qt); + push_to_lexenv(lexenv, oad->name, value); if (!NILP(oad->pred_var)) { - puthash(lexenv, oad->pred_var, Qt); + push_to_lexenv(lexenv, oad->pred_var, Qt); } break; case REST: @@ -1401,9 +1433,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, goto too_many_args; } } - puthash(lexenv, func->rest_arg, args); + push_to_lexenv(lexenv, func->rest_arg, args); // done processing - return; + goto done_adding; } args = TAIL(args); } @@ -1415,12 +1447,12 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, HASHTABLE_FOREACH(arg, desc_lv, func->kwargs, { struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv); // only check the current function's lexenv and not its parents' - if (Fgethash(lexenv, oad->name, Qunbound) == Qunbound) { + if (NILP(gethash(added_kwds, oad->name, Qnil))) { LispVal *eval_res = Feval(oad->default_form); - puthash(lexenv, oad->name, eval_res); + push_to_lexenv(lexenv, oad->name, eval_res); refcount_unref(eval_res); if (!NILP(oad->pred_var)) { - puthash(lexenv, oad->pred_var, Qnil); + push_to_lexenv(lexenv, oad->pred_var, Qnil); } } }); @@ -1428,28 +1460,31 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, FOREACH(arg, oargs) { struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg); LispVal *default_val = Feval(oad->default_form); - puthash(lexenv, oad->name, default_val); + push_to_lexenv(lexenv, oad->name, default_val); refcount_unref(default_val); if (!NILP(oad->pred_var)) { - puthash(lexenv, oad->pred_var, Qnil); + push_to_lexenv(lexenv, oad->pred_var, Qnil); } } if (!NILP(func->rest_arg)) { - puthash(lexenv, func->rest_arg, Qnil); + push_to_lexenv(lexenv, func->rest_arg, Qnil); } +done_adding: + refcount_unref(added_kwds); return; // TODO different messages missing_required: too_many_args: missing_value: unknown_key: + refcount_unref(added_kwds); Fthrow(Qargument_error, Fpair(fname, Qnil)); } static LispVal *call_lisp_function(LispVal *name, LispFunction *func, LispVal *args, LispVal *args_lexenv) { - puthash(the_stack->lexenv, Qparent_lexenv, func->lexenv); - process_lisp_args(name, func, args, the_stack->lexenv); + the_stack->lexenv = refcount_ref(func->lexenv); + process_lisp_args(name, func, args, &the_stack->lexenv); if (func->is_macro) { if (!the_stack->next) { abort(); @@ -1492,16 +1527,17 @@ static LispVal *call_function(LispVal *func, LispVal *args, // builtin macros inherit their parents lexenv 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); - } - }); + WITH_PUSH_FRAME( + SYMBOLP(func) ? func : Qlambda, args, + false, // make sure the lexenv is nil + { + the_stack->hidden = false; + if (fobj->is_builtin) { + retval = call_builtin(func, fobj, args, args_lexenv); + } else { + retval = call_lisp_function(func, fobj, args, args_lexenv); + } + }); }); cancel_cleanup(cl_handle); return retval; @@ -1560,7 +1596,6 @@ DEFUN(copy_tree, "copy-tree", (LispVal * tree)) { LispVal *copy = Qnil; LispVal *copy_end; WITH_PUSH_FRAME(Qnil, Qnil, true, { - the_stack->hidden = true; void *cl_handle = register_cleanup(&unref_double_ptr, ©); while (!NILP(tortise)) { if (!LISTP(LISPVAL(tortise))) { @@ -1609,9 +1644,10 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) { LispVal *expansion = Qnil; WITH_CLEANUP_DOUBLE_PTR(fobj, { WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, { - puthash(the_stack->lexenv, Qparent_lexenv, fobj->lexenv); + the_stack->hidden = false; + the_stack->lexenv = refcount_ref(fobj->lexenv); process_lisp_args(Fhead(form), fobj, Ftail(form), - the_stack->lexenv); + &the_stack->lexenv); expansion = Fprogn(fobj->body); }); }); @@ -1637,9 +1673,13 @@ DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) { } } -DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) { +// func should ref its return value +static LispVal *filter_body_tree(LispVal *form, + LispVal *(*func)(LispVal *body, + void *user_data), + void *user_data) { if (PAIRP(form)) { - LispVal *toplevel_orig = Fmacroexpand_toplevel(form); + LispVal *toplevel_orig = func(form, user_data); LispVal *toplevel; WITH_CLEANUP(toplevel_orig, { toplevel = Fcopy_list(toplevel_orig); // @@ -1648,7 +1688,8 @@ DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) { void *cl_handler = register_cleanup(&unref_double_ptr, &toplevel); if (PAIRP(toplevel) && NILP(Feq(Qquote, HEAD(toplevel)))) { FOREACH_TAIL(tail, TAIL(toplevel)) { - Fsethead(tail, Fmacroexpand_all(HEAD(tail))); + Fsethead(tail, + filter_body_tree(HEAD(tail), func, user_data)); } } cancel_cleanup(cl_handler); @@ -1660,6 +1701,14 @@ DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) { return Qnil; } +static LispVal *macroexpand_toplevel_as_callback(LispVal *form, void *ignored) { + return Fmacroexpand_toplevel(form); +} + +DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) { + return filter_body_tree(form, macroexpand_toplevel_as_callback, NULL); +} + DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { LispVal *args = Qnil; LispVal *end; @@ -1741,7 +1790,6 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) { LispVal *res = Feval(cond); LispVal *retval = Qnil; WITH_PUSH_FRAME(Qnil, Qnil, true, { - the_stack->hidden = true; if (!NILP(res)) { retval = Feval(t); } else { @@ -1843,16 +1891,14 @@ DEFUN(sub, "-", (LispVal * args)) { static void set_symbol_in_lexenv(LispVal *key, LispVal *newval, LispVal *lexenv) { - while (HASHTABLEP(lexenv)) { - if (gethash(lexenv, key, Qunbound) != Qunbound) { - puthash(lexenv, key, newval); - return; - } - lexenv = gethash(lexenv, Qparent_lexenv, Qnil); + LispVal *lexval = Fplist_assoc(lexenv, key, Qnil); + if (PAIRP(lexval)) { + Fsethead(TAIL(lexval), newval); + } else { + refcount_ref(newval); + refcount_unref(((LispSymbol *) key)->value); + ((LispSymbol *) key)->value = newval; } - refcount_ref(newval); - refcount_unref(((LispSymbol *) key)->value); - ((LispSymbol *) key)->value = newval; } DEFMACRO(setq, "setq", (LispVal * args)) { @@ -1890,28 +1936,127 @@ DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) { return refcount_ref(new_func); } +// clang-format off +DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) { + bool success = false; + LispVal *success_form = Qunbound; + LispVal *finally_form = Qunbound; + LispVal *retval = Qnil; + WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(Qnil, Qnil, true, { + void *cl_handler = register_cleanup(&unref_double_ptr, &success_form); + void *cl_handler2 = register_cleanup(&unref_double_ptr, &finally_form); + FOREACH(entry, rest) { + if (HEAD(entry) == Qsuccess) { + if (success_form != Qunbound) { + Fthrow(Qmalformed_lambda_list_error, Qnil); + } + success_form = Fpair(Qprogn, TAIL(entry)); + } else if (HEAD(entry) == Qfinally) { + if (finally_form != Qunbound) { + Fthrow(Qmalformed_lambda_list_error, Qnil); + } + finally_form = Fpair(Qprogn, TAIL(entry)); + } else { + LispVal *var = HEAD(HEAD(entry)); LispVal *types = HEAD(TAIL(HEAD(entry))); + if (!PAIRP(types)) { + types = const_list(true, 1, types); + } else { + types = refcount_ref(types); + } + WITH_CLEANUP(types, { + FOREACH(type, types) { + LispVal *handler = push_many(TAIL(entry), 2, + Qprogn, var); + puthash(the_stack->handlers, type, handler); + refcount_unref(handler); + } + }); + } + } + cancel_cleanup(cl_handler2); + if (finally_form != Qunbound) { + the_stack->unwind_form = finally_form; + } + retval = Feval(form); + cancel_cleanup(cl_handler); + success = true; + }, { + retval = refcount_ref(stack_return); + }); + // call this out here so it is not covered by the handlers + if (success && success_form != Qunbound) { + void *cl_handler = register_cleanup(&refcount_unref_as_callback, retval); + WITH_CLEANUP(success_form, { + refcount_unref(Feval(success_form)); + }); + cancel_cleanup(cl_handler); + } + return retval; +} +// clang-format on + +// true if the form was a declare form +static bool parse_function_declare(LispVal *form, LispVal **name_ptr) { + if (PAIRP(form) && HEAD(form) == Qdeclare) { + FOREACH(elt, TAIL(form)) { + if (name_ptr && PAIRP(elt) && HEAD(elt) == Qname + && PAIRP(TAIL(elt))) { + *name_ptr = HEAD(TAIL(elt)); + } + } + return true; + } + return false; +} + +static LispVal *expand_function_body_callback(LispVal *body, void *data) { + return Fmacroexpand_toplevel(body); +} + +static inline LispVal *expand_function_body(LispVal *body) { + return filter_body_tree(body, expand_function_body_callback, NULL); +} + DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) { CHECK_TYPE(TYPE_SYMBOL, name); - LispVal *func = make_lisp_function(args, the_stack->lexenv, body, false); + if (parse_function_declare(HEAD(body), NULL)) { + body = TAIL(body); + } + LispVal *expanded_body = expand_function_body(body); + LispVal *func = Qnil; + WITH_CLEANUP(expanded_body, { + func = make_lisp_function(name, args, the_stack->lexenv, body, false); + }); refcount_unref(Ffset(name, func)); return func; } DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) { CHECK_TYPE(TYPE_SYMBOL, name); - LispVal *func = make_lisp_function(args, the_stack->lexenv, body, true); + if (parse_function_declare(HEAD(body), NULL)) { + body = TAIL(body); + } + LispVal *expanded_body = expand_function_body(body); + LispVal *func = Qnil; + WITH_CLEANUP(expanded_body, { + func = make_lisp_function(name, args, the_stack->lexenv, body, true); + }); refcount_unref(Ffset(name, func)); return func; } DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) { + LispVal *name = Qlambda; + if (parse_function_declare(HEAD(body), &name)) { + body = TAIL(body); + } LispVal *expanded_body = Fmacroexpand_all(body); - LispVal *retval = Qnil; + LispVal *func = Qnil; WITH_CLEANUP(expanded_body, { - retval = - make_lisp_function(args, the_stack->lexenv, expanded_body, false); + func = make_lisp_function(name, args, the_stack->lexenv, expanded_body, + false); }); - return retval; + return func; } DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) { @@ -2110,6 +2255,72 @@ DEFUN(function_docstr, "function-docstr", (LispVal * func)) { return retval; } +static bool call_eq_pred(LispVal *pred, LispVal *v1, LispVal *v2) { + if (NILP(pred)) { + return !NILP(Feq(v1, v2)); + } else { + LispVal *fcall_args = const_list(true, 2, v1, v2); + bool res = false; + WITH_CLEANUP(fcall_args, { + LispVal *lvpr = Ffuncall(pred, fcall_args); // + res = !NILP(lvpr); + refcount_unref(lvpr); + }); + return res; + } +} + +DEFUN(plist_get, "plist-get", + (LispVal * plist, LispVal *key, LispVal *def, LispVal *pred)) { + for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) { + if (call_eq_pred(pred, key, HEAD(cur))) { + if (NILP(TAIL(cur))) { + return refcount_ref(def); + } + return refcount_ref(HEAD(TAIL(cur))); + } + } + return refcount_ref(def); +} + +DEFUN(plist_set, "plist-set", + (LispVal * plist, LispVal *key, LispVal *value, LispVal *pred)) { + for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) { + if (call_eq_pred(pred, key, HEAD(cur))) { + if (NILP(TAIL(cur))) { + break; + } + return refcount_ref(HEAD(TAIL(cur))); + } + } + return push_many(plist, 2, value, key); +} + +DEFUN(plist_rem, "plist-rem", (LispVal * plist, LispVal *key, LispVal *pred)) { + for (LispVal *prev = Qnil, *cur = plist; !NILP(cur); + prev = cur, cur = TAIL(TAIL(cur))) { + if (call_eq_pred(pred, key, HEAD(cur))) { + if (NILP(prev)) { + return refcount_ref(TAIL(TAIL(plist))); + } else { + Fsettail(TAIL(prev), TAIL(TAIL(cur))); + } + return Qnil; + } + } + return refcount_ref(plist); +} + +DEFUN(plist_assoc, "plist-assoc", + (LispVal * plist, LispVal *key, LispVal *pred)) { + for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) { + if (call_eq_pred(pred, key, HEAD(cur))) { + return cur; + } + } + return Qnil; +} + static void debug_dump_real(FILE *stream, void *obj, bool first) { switch (TYPEOF(obj)) { case TYPE_STRING: { @@ -2158,13 +2369,23 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) { } fputc(']', stream); } break; - case TYPE_FUNCTION: + case TYPE_FUNCTION: { + LispVal *name = ((LispFunction *) obj)->name; if (((LispFunction *) obj)->is_builtin) { - fprintf(stream, "", (uintmax_t) obj); + fprintf(stream, "", (uintmax_t) obj); + if (name == Qlambda) { + fprintf(stream, "", (uintmax_t) obj); + } break; case TYPE_HASHTABLE: { LispHashtable *tbl = (LispHashtable *) obj; fprintf(stream, "", @@ -2214,33 +2435,3 @@ static bool debug_print_tree_callback(void *obj, const RefcountList *trail, void debug_print_tree(FILE *stream, void *obj) { refcount_debug_walk_tree(obj, debug_print_tree_callback, stream); } - -void debug_dump_lexenv(FILE *stream, LispVal *lexenv) { - if (!the_stack) { - fprintf(stream, "debug_dump_lexenv: No stack frames...\n"); - } - if (!lexenv) { - lexenv = the_stack->lexenv; - } - bool first = true; - while (!NILP(lexenv)) { - if (first) { - fprintf(stream, "Lexical variables (most recent frame first):\n"); - } else { - fprintf(stream, "\nNext parent:\n"); - } - first = false; - LispVal *next_lexenv = Qnil; - HASHTABLE_FOREACH(var, val, lexenv, { - if (var == Qparent_lexenv) { - next_lexenv = val; - } else { - fprintf(stream, " - "); - debug_dump(stream, var, false); - fprintf(stream, " -> "); - debug_dump(stream, val, true); - } - }); - lexenv = next_lexenv; - } -} diff --git a/src/lisp.h b/src/lisp.h index 7b5bf67..08796a5 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -107,6 +107,7 @@ typedef void (*lisp_function_ptr_t)(void); typedef struct { LISP_OBJECT_HEADER; + LispVal *name; LispVal *doc; LispVal *args; bool is_builtin; @@ -217,16 +218,16 @@ inline static bool NUMBERP(LispVal *v) { .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, \ - .name = &_Q##c_name##_name, \ - .plist = Qnil, \ - .function = Qunbound, \ - .value = Qunbound, \ - .is_constant = false, \ - }; \ +#define DEF_STATIC_SYMBOL(c_name, lisp_name) \ + DEF_STATIC_STRING(_Q##c_name##_symnamestr, lisp_name); \ + static LispSymbol _Q##c_name = { \ + .type = TYPE_SYMBOL, \ + .name = &_Q##c_name##_symnamestr, \ + .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; \ @@ -234,12 +235,14 @@ inline static bool NUMBERP(LispVal *v) { // The args and doc fields are filled when the function is registered #define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args, static_kw) \ static_kw LispVal *F##c_name c_args; \ - DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \ + DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name); \ + static LispSymbol _Q##c_name; \ static LispFunction _Q##c_name##_function = { \ .type = TYPE_FUNCTION, \ .is_builtin = true, \ .is_macro = macrop, \ .builtin = (void (*)(void)) & F##c_name, \ + .name = LISPVAL(&_Q##c_name), \ .doc = Qnil, \ .args = Qnil, \ .rargs = Qnil, \ @@ -250,7 +253,7 @@ inline static bool NUMBERP(LispVal *v) { }; \ static LispSymbol _Q##c_name = { \ .type = TYPE_SYMBOL, \ - .name = &_Q##c_name##_name, \ + .name = &_Q##c_name##_fnnamestr, \ .plist = Qnil, \ .value = Qunbound, \ .function = LISPVAL(&_Q##c_name##_function), \ @@ -315,8 +318,8 @@ 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 *lexenv, LispVal *body, - bool is_macro); +LispVal *make_lisp_function(LispVal *name, LispVal *args, LispVal *lexenv, + LispVal *body, bool is_macro); LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn); LispVal *make_user_pointer(void *data, void (*free_func)(void *)); #define ALLOC_USERPTR(type, free_func) \ @@ -388,6 +391,28 @@ static inline LispVal *make_list(size_t len, LispVal **vals) { } return list; } +static inline LispVal *push_many(LispVal *list, int count, ...) { + LispVal *new_list = list; + bool first = true; + va_list args; + va_start(args, count); + while (count--) { + new_list = Fpair(va_arg(args, LispVal *), new_list); + if (!first) { + refcount_unref(((LispPair *) new_list)->tail); + first = false; + } + } + va_end(args); + return new_list; +} +static inline void push_to_lexenv(LispVal **lexenv, LispVal *key, + LispVal *value) { + LispVal *old = *lexenv; + *lexenv = push_many(*lexenv, 2, value, key); + refcount_unref(old); +} + typedef void (*lisp_cleanup_func_t)(void *); struct CleanupHandlerEntry { struct CleanupHandlerEntry *next; @@ -402,15 +427,18 @@ typedef struct StackFrame { LispVal *lexenv; // symbol -> value bool enable_handlers; LispVal *handlers; // symbol -> (error-var form) - LispVal *unwind_forms; + LispVal *unwind_form; struct CleanupHandlerEntry *cleanup_handlers; jmp_buf start; } StackFrame; +#define STACK_EXIT_NORMAL 0 +#define STACK_EXIT_THROW 1 + extern StackFrame *the_stack; +extern LispVal *stack_return; extern LispVal *Qtoplevel; -extern LispVal *Qparent_lexenv; void stack_enter(LispVal *name, LispVal *detail, bool inherit); void stack_leave(void); @@ -423,15 +451,26 @@ 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_NO_REF_HANDLING_THROWS(name, detail, inherit, body, \ + on_return) \ + stack_enter(name, detail, inherit); \ + { \ + int __with_push_frame_jmpval = setjmp(the_stack->start); \ + if (__with_push_frame_jmpval == STACK_EXIT_NORMAL) { \ + body \ + } else if (__with_push_frame_jmpval == STACK_EXIT_THROW) { \ + on_return; \ + refcount_unref(stack_return); \ + stack_return = NULL; \ + } \ + stack_leave(); \ + } #define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \ - stack_enter(name, detail, inherit); \ - if (setjmp(the_stack->start) == 0) { \ - body \ - } \ - stack_leave(); + WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, 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( \ @@ -450,8 +489,11 @@ void cancel_cleanup(void *handle); } DECLARE_FUNCTION(backtrace, (void) ); +noreturn DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value)); noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest)); +extern LispVal *Qsuccess; +extern LispVal *Qfinally; extern LispVal *Qshutdown_signal; extern LispVal *Qtype_error; extern LispVal *Qread_error; @@ -463,6 +505,7 @@ extern LispVal *Qmalformed_lambda_list_error; extern LispVal *Qargument_error; extern LispVal *Qinvalid_function_error; extern LispVal *Qno_applicable_method_error; +extern LispVal *Qreturn_frame_error; LispVal *predicate_for_type(LispType type); #define CHECK_TYPE(type, val) \ @@ -528,6 +571,7 @@ DECLARE_FUNCTION(sub, (LispVal * args)); DECLARE_FUNCTION(setq, (LispVal * args)); DECLARE_FUNCTION(progn, (LispVal * forms)); DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func)); +DECLARE_FUNCTION(condition_case, (LispVal * form, LispVal *rest)); DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body)); DECLARE_FUNCTION(defmacro, (LispVal * name, LispVal *args, LispVal *body)); DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body)); @@ -561,6 +605,12 @@ DECLARE_FUNCTION(and, (LispVal * rest)); DECLARE_FUNCTION(or, (LispVal * rest)); DECLARE_FUNCTION(type_of, (LispVal * val)); DECLARE_FUNCTION(function_docstr, (LispVal * func)); +DECLARE_FUNCTION(plist_get, + (LispVal * plist, LispVal *key, LispVal *def, LispVal *pred)); +DECLARE_FUNCTION(plist_set, (LispVal * plist, LispVal *key, LispVal *value, + LispVal *pred)); +DECLARE_FUNCTION(plist_rem, (LispVal * plist, LispVal *key, LispVal *pred)); +DECLARE_FUNCTION(plist_assoc, (LispVal * plist, LispVal *key, LispVal *pred)); void debug_dump(FILE *stream, void *obj, bool newline); void debug_print_hashtable(FILE *stream, LispVal *table); @@ -570,7 +620,8 @@ extern LispVal *Qopt; extern LispVal *Qkey; extern LispVal *Qallow_other_keys; extern LispVal *Qrest; -extern LispVal *Qreturn_signal; +extern LispVal *Qdeclare; +extern LispVal *Qname; // some internal functions LispVal *puthash(LispVal *table, LispVal *key, LispVal *value); diff --git a/src/main.c b/src/main.c index 5743421..682b8da 100644 --- a/src/main.c +++ b/src/main.c @@ -88,7 +88,6 @@ int main(int argc, const char **argv) { REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", ""); 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