diff --git a/src/kernel.sl b/src/kernel.sl index 5d30198..b232867 100644 --- a/src/kernel.sl +++ b/src/kernel.sl @@ -257,3 +257,82 @@ (and negate (not (funcall pred cur)))) (return-from find-if cur))) default) + +(defun mapconcat (func list) + (let (start end) + (dolist (elt list) + (if (not start) + (setq start (copy-list (funcall func elt)) + end (lasttail start)) + (settail end (copy-list (funcall func elt))) + (setq end (lasttail end)))) + start)) + +(defun identity (e) e) + +(defun append (&rest lists) + ;; another implementation + ;; (mapconcat 'identity lists) + (let* ((start (copy-list (head lists))) + (end (lasttail start))) + (dolist (list (tail lists)) + (settail end (copy-list list)) + (setq end (lasttail end))) + start)) + +(defmacro macrolet (macros &rest body) + (let* ((found-macros (make-hashtable)) + (macro-fns (mapconcat (lambda (entry) + (let ((name (first entry)) + (args (second entry)) + (body (tail (tail entry)))) + (when (gethash found-macros name) + (throw 'argument-error)) + (puthash found-macros name t) + (list name + (eval (apply 'list 'lambda args + (list 'declare (list 'name name)) + body))))) + macros))) + (macroexpand-all (pair 'progn body) macro-fns))) + +(defmacro flet (functions &rest body) + (let ((macros (maphead (lambda (entry) + (let* ((name (first entry)) + (args (second entry)) + (body (tail (tail entry))) + (the-func + (eval (apply 'list 'lambda args + (list 'declare (list 'name name)) + body))) + (the-sym (make-symbol (symbol-name name)))) + (fset the-sym the-func) + (list name '(&rest args) + (list 'apply ''list (list '\' the-sym) 'args)))) + functions))) + (apply 'list 'macrolet macros body))) + +(defmacro labels (functions &rest body) + (let ((syms (make-hashtable))) + (dolist (entry functions) + (when (gethash syms (first entry)) + (throw 'argument-error)) + (puthash syms (first entry) (make-symbol (symbol-name (first entry))))) + (let* ((macros (mapconcat + (lambda (entry) + (list (first entry) + (eval (list 'lambda '(&rest args) + (list 'apply ''list + (list '\' (gethash syms (first entry))) + 'args))))) + functions))) + (dolist (entry functions) + (let ((name (first entry)) + (args (second entry)) + (body (tail (tail entry)))) + (fset (gethash syms name) + (eval (apply 'list 'lambda args + (list 'declare (list 'name name)) + (tail (macroexpand-all (pair 'progn body) + macros))))))) + (macroexpand-all (pair 'progn body) macros)))) diff --git a/src/lisp.c b/src/lisp.c index 57f5dd2..c2406b9 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -422,6 +422,23 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)) { return LISPVAL(self); } +DEFUN(make_hashtable, "make-hashtable", (LispVal * hash_fn, LispVal *eq_fn)) { + return make_lisp_hashtable(eq_fn, hash_fn); +} + +DEFUN(vector, "vector", (LispVal * elems)) { + struct UnrefListData uld = {.vals = NULL, .len = 0}; + WITH_PUSH_FRAME(Qnil, Qnil, true, { + void *cl_handler = register_cleanup(&unref_free_list_double_ptr, &uld); + FOREACH(elt, elems) { + uld.vals = lisp_realloc(uld.vals, sizeof(LispVal *) * (++uld.len)); + uld.vals[uld.len - 1] = elt; + } + cancel_cleanup(cl_handler); + }); + return make_lisp_vector(uld.vals, uld.len); +} + DEFUN(pair, "pair", (LispVal * head, LispVal *tail)) { return make_lisp_pair(head, tail); } @@ -1068,6 +1085,11 @@ void lisp_init(void) { REGISTER_STATIC_FUNCTION(set_for_return, "(entry dest)", ""); REGISTER_STATIC_FUNCTION(internal_real_return, "(name tag value)", ""); + REGISTER_FUNCTION(make_hashtable, "(&opt hash-fn eq-fn)", ""); + REGISTER_FUNCTION(puthash, "(table key value)", ""); + REGISTER_FUNCTION(gethash, "(table key &opt def)", ""); + REGISTER_FUNCTION(remhash, "(table key)", ""); + REGISTER_FUNCTION(vector, "(&rest elements)", ""); REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing..."); REGISTER_FUNCTION(sethead, "(pair newval)", "Set the head of PAIR to NEWVAL."); @@ -1100,6 +1122,7 @@ void lisp_init(void) { setq, "(&rest name-value-pairs)", "Set each of a number of variables to their respective values."); REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS."); + REGISTER_FUNCTION(symbol_name, "(sym)", ""); 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."); @@ -1120,10 +1143,10 @@ void lisp_init(void) { "Return non-nil if OBJ1 and OBJ2 are equal"); REGISTER_FUNCTION(make_symbol, "(name)", "Return a new un-interned symbol named NAME."); - REGISTER_FUNCTION(macroexpand_1, "(form)", + REGISTER_FUNCTION(macroexpand_1, "(form &opt lexical-macros)", "Return the form which FORM expands to."); - REGISTER_FUNCTION(macroexpand_toplevel, "(form)", ""); - REGISTER_FUNCTION(macroexpand_all, "(form)", ""); + REGISTER_FUNCTION(macroexpand_toplevel, "(form &opt lexical-macros)", ""); + REGISTER_FUNCTION(macroexpand_all, "(form &opt lexical-macros)", ""); 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."); @@ -1133,7 +1156,7 @@ void lisp_init(void) { REGISTER_FUNCTION( functionp, "(val)", "Return non-nil if VAL is a non-macro function (includes buitlins)."); - REGISTER_FUNCTION(macrop, "(val)", + REGISTER_FUNCTION(macrop, "(val &opt lexical-macros)", "Return non-nil if VAL is a non-builtin macro."); REGISTER_FUNCTION(builtinp, "(val)", "Return non-nil if VAL is a non-macro builtin."); @@ -1210,6 +1233,11 @@ DEFUN(breakpoint, "breakpoint", (LispVal * id)) { return Qnil; } +DEFUN(symbol_name, "symbol-name", (LispVal * symbol)) { + CHECK_TYPE(TYPE_SYMBOL, symbol); + return refcount_ref(((LispSymbol *) symbol)->name); +} + DEFUN(symbol_function, "symbol-function", (LispVal * symbol, LispVal *resolve)) { CHECK_TYPE(TYPE_SYMBOL, symbol); @@ -1707,10 +1735,32 @@ DEFUN(copy_tree, "copy-tree", (LispVal * tree)) { return copy; } -DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) { +static LispVal *lookup_lexical_macro(LispVal *name, LispVal *lexical_macros) { + if (!SYMBOLP(name)) { + return Qunbound; + } + LispVal *res = Fplist_get(lexical_macros, name, Qunbound, Qnil); + if (FUNCTIONP(res)) { + return res; + } + refcount_unref(res); + return Qunbound; +} + +static inline LispVal *expand_function_as_macro(LispFunction *fobj, + LispVal *args) { + return Ffuncall((LispVal *) fobj, args); +} + +DEFUN(macroexpand_1, "macroexpand-1", + (LispVal * form, LispVal *lexical_macros)) { if (PAIRP(form)) { - LispFunction *fobj; - if (FUNCTIONP(HEAD(form))) { + LispVal *lex_res = lookup_lexical_macro(HEAD(form), lexical_macros); + LispFunction *fobj = (LispFunction *) Qunbound; + if (lex_res != Qunbound) { + return expand_function_as_macro((LispFunction *) lex_res, + TAIL(form)); + } else if (FUNCTIONP(HEAD(form))) { fobj = refcount_ref(HEAD(form)); } else { fobj = (LispFunction *) Fsymbol_function(HEAD(form), Qt); @@ -1748,12 +1798,13 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) { } } -DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) { +DEFUN(macroexpand_toplevel, "macroexpand-toplevel", + (LispVal * form, LispVal *lexical_macros)) { 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); + while (PAIRP(out) && !NILP(Fmacrop(HEAD(out), lexical_macros))) { + LispVal *new_out = Fmacroexpand_1(out, lexical_macros); refcount_unref(out); out = new_out; } @@ -1942,12 +1993,15 @@ static LispVal *filter_body_tree(LispVal *body, return start; } -static LispVal *macroexpand_toplevel_as_callback(LispVal *form, void *ignored) { - return Fmacroexpand_toplevel(form); +static LispVal *macroexpand_toplevel_as_callback(LispVal *form, + void *lexical_macros) { + return Fmacroexpand_toplevel(form, lexical_macros); } -DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) { - return filter_body_form(form, macroexpand_toplevel_as_callback, NULL); +DEFUN(macroexpand_all, "macroexpand-all", + (LispVal * form, LispVal *lexical_macros)) { + return filter_body_form(form, macroexpand_toplevel_as_callback, + lexical_macros); } DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { @@ -2257,7 +2311,7 @@ struct NameAndReturnTag { static LispVal *expand_function_body_callback(LispVal *body, void *data) { struct NameAndReturnTag *name_and_return_tag = data; - LispVal *expansion = Fmacroexpand_toplevel(body); + LispVal *expansion = Fmacroexpand_toplevel(body, Qnil); // this mess checks that the call is exactly one of // - (return-from 'symbol) // - (return-from 'symbol val) @@ -2292,7 +2346,7 @@ static inline LispVal *expand_function_body(LispVal *name, LispVal *return_tag, } static LispVal *macroexpand_all_as_callback(LispVal *form, void *ignored) { - return Fmacroexpand_all(form); + return Fmacroexpand_all(form, Qnil); } static inline void expand_lambda_list_for_toplevel(LispVal *list) { @@ -2432,11 +2486,14 @@ DEFUN(functionp, "functionp", (LispVal * val)) { return Qnil; } -DEFUN(macrop, "macrop", (LispVal * val)) { +DEFUN(macrop, "macrop", (LispVal * val, LispVal *lexical_macros)) { if (FUNCTIONP(val) && !((LispFunction *) val)->is_builtin && ((LispFunction *) val)->is_macro) { return Qt; } else if (SYMBOLP(val)) { + if (lookup_lexical_macro(val, lexical_macros) != Qunbound) { + return Qt; + } LispVal *res = Fsymbol_function(val, Qt); LispVal *retval = LISP_BOOL(FUNCTIONP(res) && !((LispFunction *) res)->is_builtin diff --git a/src/lisp.h b/src/lisp.h index 572b7ea..a5633db 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -333,6 +333,7 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)); // ######################## bool strings_equal_nocase(const char *s1, const char *s2, size_t n); +DECLARE_FUNCTION(make_hashtable, (LispVal * hash_fn, LispVal *eq_fn)); DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail)); DECLARE_FUNCTION(hash_string, (LispVal * obj)); DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2)); @@ -565,6 +566,7 @@ extern LispVal *Qcomma_at; DECLARE_FUNCTION(quote, (LispVal * form)); DECLARE_FUNCTION(breakpoint, (LispVal * id)); +DECLARE_FUNCTION(symbol_name, (LispVal * symbol)); DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve)); DECLARE_FUNCTION(symbol_value, (LispVal * symbol)); DECLARE_FUNCTION(symbol_plist, (LispVal * symbol)); @@ -593,9 +595,10 @@ DECLARE_FUNCTION(defmacro, (LispVal * name, LispVal *args, LispVal *body)); 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(macroexpand_1, (LispVal * form, LispVal *lexical_macros)); +DECLARE_FUNCTION(macroexpand_toplevel, + (LispVal * form, LispVal *lexical_macros)); +DECLARE_FUNCTION(macroexpand_all, (LispVal * form, LispVal *lexical_macros)); DECLARE_FUNCTION(stringp, (LispVal * val)); DECLARE_FUNCTION(symbolp, (LispVal * val)); DECLARE_FUNCTION(pairp, (LispVal * val)); @@ -603,7 +606,7 @@ DECLARE_FUNCTION(integerp, (LispVal * val)); DECLARE_FUNCTION(floatp, (LispVal * val)); DECLARE_FUNCTION(vectorp, (LispVal * val)); DECLARE_FUNCTION(functionp, (LispVal * val)); -DECLARE_FUNCTION(macrop, (LispVal * val)); +DECLARE_FUNCTION(macrop, (LispVal * val, LispVal *lexical_macros)); DECLARE_FUNCTION(builtinp, (LispVal * val)); DECLARE_FUNCTION(special_form_p, (LispVal * val)); DECLARE_FUNCTION(hashtablep, (LispVal * val));