From 91f2ab8e0ab7c16ce13816af9fa15a7de0ebf66b Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Mon, 15 Sep 2025 01:12:54 -0700 Subject: [PATCH] Some random work --- src/{kernel.el => kernel.sl} | 85 +++++++++---- src/lisp.c | 225 +++++++++++++++++++++++++++++++++-- src/lisp.h | 68 ++++++----- 3 files changed, 322 insertions(+), 56 deletions(-) rename src/{kernel.el => kernel.sl} (65%) diff --git a/src/kernel.el b/src/kernel.sl similarity index 65% rename from src/kernel.el rename to src/kernel.sl index 7fd739d..05a8f1c 100644 --- a/src/kernel.el +++ b/src/kernel.sl @@ -3,6 +3,11 @@ (fset 'null 'not) (defun list (&rest r) r) +(defun ensure-list (arg) + (if (pairp arg) + arg + (list arg))) + (fset 'first 'head) (defun second (list) (head (tail list))) @@ -23,6 +28,12 @@ (defun tenth (list) (head (tail (tail (tail (tail (tail (tail (tail (tail (tail list))))))))))) +(defmacro when (cond &rest body) + (list 'if cond (pair 'progn body))) + +(defmacro unless (cond &rest body) + (apply 'list 'if cond nil body)) + (defmacro dolist (vars &rest body) (funcall (lambda (tail-var) @@ -77,13 +88,27 @@ (apply 'list 'funcall (apply 'list 'lambda (reverse vars) 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) - (while list - (setq out list - list (tail list))) - out)) + (while list + (setq out list + list (tail list))) + out)) (defun internal-expand-single-cond (cond) (if (tail cond) @@ -104,22 +129,40 @@ (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 tcase (obj &rest conds) + (let ((obj-var (make-symbol "obj"))) + (list 'let (list (list obj-var obj)) + (pair + 'cond + (maphead + (lambda (cond) + (let ((pred (pair 'or (maphead + (lambda (elt) + (if (eq elt t) + t + (list 'eq (list 'type-of obj-var) + (list '\' elt)))) + (ensure-list (head cond)))))) + (pair pred (tail cond)))) + conds))))) + +(defun internal-expand-\` (form &opt (level 0)) + (tcase + (()))) (defmacro \` (form) - (list '\' (head (internal-expand-\` 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))) diff --git a/src/lisp.c b/src/lisp.c index 5bff946..41f7456 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -680,7 +680,8 @@ size_t list_length(LispVal *obj) { StackFrame *the_stack = NULL; DEF_STATIC_SYMBOL(toplevel, "toplevel"); -DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv"); +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)); @@ -1045,6 +1046,10 @@ void lisp_init(void) { "Set each of a number of variables to their respective values."); REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS."); REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", ""); + REGISTER_FUNCTION(symbol_value, "(sym)", "Return the global value of SYM."); + REGISTER_FUNCTION(symbol_plist, "(sym)", "Return the plist of SYM."); + REGISTER_FUNCTION(setplist, "(sym plist)", + "Set the plist of SYM to PLIST."); REGISTER_FUNCTION(fset, "(sym new-func)", ""); REGISTER_FUNCTION(defun, "(name args &rest body)", "Define NAME to be a new function."); @@ -1062,15 +1067,23 @@ void lisp_init(void) { "Return a new un-interned symbol named NAME."); REGISTER_FUNCTION(macroexpand_1, "(form)", "Return the form which FORM expands to."); + REGISTER_FUNCTION(macroexpand_toplevel, "(form)", ""); + REGISTER_FUNCTION(macroexpand_all, "(form)", ""); REGISTER_FUNCTION(stringp, "(val)", "Return non-nil if VAL is a string."); REGISTER_FUNCTION(symbolp, "(val)", "Return non-nil if VAL is a symbol."); REGISTER_FUNCTION(pairp, "(val)", "Return non-nil if VAL is a pair."); REGISTER_FUNCTION(integerp, "(val)", "Return non-nil if VAL is a integer."); REGISTER_FUNCTION(floatp, "(val)", "Return non-nil if VAL is a float."); REGISTER_FUNCTION(vectorp, "(val)", "Return non-nil if VAL is a vector."); - REGISTER_FUNCTION(functionp, "(val)", - "Return non-nil if VAL is a function."); - REGISTER_FUNCTION(macrop, "(val)", "Return non-nil if VAL is a macro."); + REGISTER_FUNCTION( + functionp, "(val)", + "Return non-nil if VAL is a non-macro function (includes buitlins)."); + REGISTER_FUNCTION(macrop, "(val)", + "Return non-nil if VAL is a non-builtin macro."); + REGISTER_FUNCTION(builtinp, "(val)", + "Return non-nil if VAL is a non-macro builtin."); + REGISTER_FUNCTION(special_form_p, "(val)", + "Return non-nil if VAL is a macro-builtin."); REGISTER_FUNCTION(hashtablep, "(val)", "Return non-nil if VAL is a hashtable."); REGISTER_FUNCTION(user_pointer_p, "(val)", @@ -1080,6 +1093,9 @@ void lisp_init(void) { REGISTER_FUNCTION(keywordp, "(val)", "Return non-nil if VAL is a keyword."); REGISTER_FUNCTION(numberp, "(val)", "Return non-nil if VAL is a number."); REGISTER_FUNCTION(list_length, "(list)", "Return the length of LIST."); + REGISTER_FUNCTION(copy_list, "(list)", "Return a shallow copy of LIST."); + REGISTER_FUNCTION(copy_tree, "(tree)", + "Return a deep copy of TREE and all sublists in it."); REGISTER_FUNCTION(num_eq, "(n1 n2)", "Return non-nil if N1 and N2 are equal numerically.") REGISTER_FUNCTION(num_gt, "(n1 n2)", @@ -1158,6 +1174,19 @@ DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) { return refcount_ref(((LispSymbol *) symbol)->value); } +DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + return refcount_ref(((LispSymbol *) symbol)->plist); +} + +DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + LispSymbol *real = (LispSymbol *) symbol; + refcount_unref(real->plist); + real->plist = refcount_ref(plist); + return Qnil; +} + static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) { LispVal *final_args = Qnil; WITH_PUSH_FRAME(Qnil, Qnil, true, { @@ -1521,6 +1550,55 @@ DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) { return call_function(function, rest, Qnil, false, false); } +DEFUN(copy_tree, "copy-tree", (LispVal * tree)) { + if (NILP(tree)) { + return Qnil; + } + CHECK_TYPE(TYPE_PAIR, tree); + LispPair *tortise = (LispPair *) tree; + LispPair *hare = (LispPair *) tortise->tail; + 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))) { + break; + } else if (tortise == hare) { + refcount_unref(copy); + Fthrow(Qcircular_error, Qnil); + } + LispVal *elt = tortise->head; + if (PAIRP(elt)) { + elt = Fcopy_tree(elt); + } else { + refcount_ref(elt); + } + if (NILP(copy)) { + copy = Fpair(elt, Qnil); + copy_end = copy; + } else { + LispVal *new_end = Fpair(elt, Qnil); + Fsettail(copy_end, new_end); + refcount_unref(new_end); + copy_end = new_end; + } + refcount_unref(elt); + 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; + } + } + } + cancel_cleanup(cl_handle); + }); + return copy; +} + DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) { if (PAIRP(form)) { LispFunction *fobj = (LispFunction *) Fsymbol_function(Fhead(form), Qt); @@ -1543,6 +1621,45 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) { } } +DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) { + if (PAIRP(form)) { + LispVal *out = refcount_ref(form); + void *cl_handler = register_cleanup(&unref_double_ptr, &out); + while (PAIRP(out) && !NILP(Fmacrop(HEAD(out)))) { + LispVal *new_out = Fmacroexpand_1(out); + refcount_unref(out); + out = new_out; + } + cancel_cleanup(cl_handler); + return out; + } else { + return refcount_ref(form); + } +} + +DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) { + if (PAIRP(form)) { + LispVal *toplevel_orig = Fmacroexpand_toplevel(form); + LispVal *toplevel; + WITH_CLEANUP(toplevel_orig, { + toplevel = Fcopy_list(toplevel_orig); // + }); + WITH_PUSH_FRAME(Qnil, Qnil, true, { + 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))); + } + } + cancel_cleanup(cl_handler); + }); + return toplevel; + } else { + return refcount_ref(form); + } + return Qnil; +} + DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { LispVal *args = Qnil; LispVal *end; @@ -1788,7 +1905,13 @@ DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) { } DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) { - return make_lisp_function(args, the_stack->lexenv, body, false); + LispVal *expanded_body = Fmacroexpand_all(body); + LispVal *retval = Qnil; + WITH_CLEANUP(expanded_body, { + retval = + make_lisp_function(args, the_stack->lexenv, expanded_body, false); + }); + return retval; } DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) { @@ -1842,12 +1965,44 @@ DEFUN(functionp, "functionp", (LispVal * val)) { } DEFUN(macrop, "macrop", (LispVal * val)) { - if (FUNCTIONP(val) && ((LispFunction *) val)->is_macro) { + if (FUNCTIONP(val) && !((LispFunction *) val)->is_builtin + && ((LispFunction *) val)->is_macro) { return Qt; } else if (SYMBOLP(val)) { LispVal *res = Fsymbol_function(val, Qt); LispVal *retval = - LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_macro); + LISP_BOOL(FUNCTIONP(res) && !((LispFunction *) res)->is_builtin + && ((LispFunction *) res)->is_macro); + refcount_unref(res); + return retval; + } + return Qnil; +} + +DEFUN(builtinp, "builtinp", (LispVal * val)) { + if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin + && !((LispFunction *) val)->is_macro) { + return Qt; + } else if (SYMBOLP(val)) { + LispVal *res = Fsymbol_function(val, Qt); + LispVal *retval = + LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin + && !((LispFunction *) res)->is_macro); + refcount_unref(res); + return retval; + } + return Qnil; +} + +DEFUN(special_form_p, "special-form-p", (LispVal * val)) { + if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin + && ((LispFunction *) val)->is_macro) { + return Qt; + } else if (SYMBOLP(val)) { + LispVal *res = Fsymbol_function(val, Qt); + LispVal *retval = + LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin + && ((LispFunction *) res)->is_macro); refcount_unref(res); return retval; } @@ -1882,6 +2037,31 @@ DEFUN(list_length, "list-length", (LispVal * list)) { return make_lisp_integer(list_length(list)); } +DEFUN(copy_list, "copy-list", (LispVal * list)) { + if (NILP(list)) { + return Qnil; + } + CHECK_TYPE(TYPE_PAIR, list); + LispVal *copy = Qnil; + LispVal *copy_end; + WITH_PUSH_FRAME(Qnil, Qnil, true, { + void *cl_cleanup = register_cleanup(&unref_double_ptr, ©); + FOREACH(elt, list) { + if (NILP(copy)) { + copy = Fpair(elt, Qnil); + copy_end = copy; + } else { + LispVal *new_end = Fpair(elt, Qnil); + Fsettail(copy_end, new_end); + refcount_unref(new_end); + copy_end = new_end; + } + } + cancel_cleanup(cl_cleanup); + }); + return copy; +} + DEFMACRO(and, "and", (LispVal * rest)) { LispVal *retval = Qnil; FOREACH(cond, rest) { @@ -1915,6 +2095,7 @@ DEFUN(type_of, "type-of", (LispVal * obj)) { make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name, LISP_TYPE_NAMES[obj->type].len, true, true); LispVal *sym = Fintern(name); + refcount_unref(name); return sym; } @@ -2033,3 +2214,33 @@ 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 67d2406..7b5bf67 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -232,36 +232,38 @@ inline static bool NUMBERP(LispVal *v) { LispVal *F##c_name args; \ extern LispVal *Q##c_name // The args and doc fields are filled when the function is registered -#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, \ - .is_builtin = true, \ - .is_macro = macrop, \ - .builtin = (void (*)(void)) & F##c_name, \ - .doc = Qnil, \ - .args = Qnil, \ - .rargs = Qnil, \ - .oargs = Qnil, \ - .rest_arg = Qnil, \ - .kwargs = Qnil, \ - .lexenv = Qnil, \ - }; \ - static LispSymbol _Q##c_name = { \ - .type = TYPE_SYMBOL, \ - .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 _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); \ + static LispFunction _Q##c_name##_function = { \ + .type = TYPE_FUNCTION, \ + .is_builtin = true, \ + .is_macro = macrop, \ + .builtin = (void (*)(void)) & F##c_name, \ + .doc = Qnil, \ + .args = Qnil, \ + .rargs = Qnil, \ + .oargs = Qnil, \ + .rest_arg = Qnil, \ + .kwargs = Qnil, \ + .lexenv = Qnil, \ + }; \ + static LispSymbol _Q##c_name = { \ + .type = TYPE_SYMBOL, \ + .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; \ + static_kw LispVal *F##c_name c_args #define DEFUN(c_name, lisp_name, c_args) \ - _INTERNAL_DEFUN_EXTENDED(false, 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) + _INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args, ) +#define STATIC_DEFUN(c_name, lisp_name, c_args) \ + _INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args, static) // ############### // # Loop macros # @@ -506,6 +508,8 @@ DECLARE_FUNCTION(quote, (LispVal * form)); DECLARE_FUNCTION(breakpoint, (LispVal * id)); DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve)); DECLARE_FUNCTION(symbol_value, (LispVal * symbol)); +DECLARE_FUNCTION(symbol_plist, (LispVal * symbol)); +DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist)); DECLARE_FUNCTION(eval_in_env, (LispVal * form, LispVal *lexenv)); DECLARE_FUNCTION(eval, (LispVal * form)); DECLARE_FUNCTION(funcall, (LispVal * function, LispVal *rest)); @@ -530,6 +534,8 @@ DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body)); DECLARE_FUNCTION(while, (LispVal * condition, LispVal *body)); DECLARE_FUNCTION(make_symbol, (LispVal * name)); DECLARE_FUNCTION(macroexpand_1, (LispVal * form)); +DECLARE_FUNCTION(macroexpand_toplevel, (LispVal * form)); +DECLARE_FUNCTION(macroexpand_all, (LispVal * form)); DECLARE_FUNCTION(stringp, (LispVal * val)); DECLARE_FUNCTION(symbolp, (LispVal * val)); DECLARE_FUNCTION(pairp, (LispVal * val)); @@ -538,6 +544,8 @@ DECLARE_FUNCTION(floatp, (LispVal * val)); DECLARE_FUNCTION(vectorp, (LispVal * val)); DECLARE_FUNCTION(functionp, (LispVal * val)); DECLARE_FUNCTION(macrop, (LispVal * val)); +DECLARE_FUNCTION(builtinp, (LispVal * val)); +DECLARE_FUNCTION(special_form_p, (LispVal * val)); DECLARE_FUNCTION(hashtablep, (LispVal * val)); DECLARE_FUNCTION(user_pointer_p, (LispVal * val)); DECLARE_FUNCTION(atom, (LispVal * val)); @@ -545,6 +553,8 @@ DECLARE_FUNCTION(listp, (LispVal * val)); DECLARE_FUNCTION(keywordp, (LispVal * val)); DECLARE_FUNCTION(numberp, (LispVal * val)); DECLARE_FUNCTION(list_length, (LispVal * list)); +DECLARE_FUNCTION(copy_list, (LispVal * list)); +DECLARE_FUNCTION(copy_tree, (LispVal * tree)); DECLARE_FUNCTION(num_eq, (LispVal * n1, LispVal *n2)); DECLARE_FUNCTION(num_gt, (LispVal * n1, LispVal *n2)); DECLARE_FUNCTION(and, (LispVal * rest)); @@ -555,10 +565,12 @@ DECLARE_FUNCTION(function_docstr, (LispVal * func)); void debug_dump(FILE *stream, void *obj, bool newline); void debug_print_hashtable(FILE *stream, LispVal *table); void debug_print_tree(FILE *stream, void *obj); +void debug_dump_lexenv(FILE *stream, LispVal *lexenv); extern LispVal *Qopt; extern LispVal *Qkey; extern LispVal *Qallow_other_keys; extern LispVal *Qrest; +extern LispVal *Qreturn_signal; // some internal functions LispVal *puthash(LispVal *table, LispVal *key, LispVal *value);