Labels, flet, and macrolet!

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))))

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_toplevel, "(form &opt lexical-macros)", "");
-    REGISTER_FUNCTION(macroexpand_all, "(form)", "");
+    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;
+        LispVal *lex_res = lookup_lexical_macro(HEAD(form), lexical_macros);
-        if (FUNCTIONP(HEAD(form))) {
+        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)))) {
+        while (PAIRP(out) && !NILP(Fmacrop(HEAD(out), lexical_macros))) {
-            LispVal *new_out = Fmacroexpand_1(out);
+            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) {
+static LispVal *macroexpand_toplevel_as_callback(LispVal *form,
-    return Fmacroexpand_toplevel(form);
+                                                 void *lexical_macros) {
+    return Fmacroexpand_toplevel(form, lexical_macros);
 }
 
-DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
+DEFUN(macroexpand_all, "macroexpand-all",
-    return filter_body_form(form, macroexpand_toplevel_as_callback, NULL);
+      (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

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_1, (LispVal * form, LispVal *lexical_macros));
-DECLARE_FUNCTION(macroexpand_toplevel, (LispVal * form));
+DECLARE_FUNCTION(macroexpand_toplevel,
-DECLARE_FUNCTION(macroexpand_all, (LispVal * form));
+                 (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));