Macro expansion!

lisp/kernel.gl

@@ -1,3 +1,7 @@
 ;; -*- mode: lisp-data -*-
 
-(function-arity (lambda (y &optional x x)))
+(fset 'test (cons 'macro (lambda (x) (declare (name test)) (list 'princ x))))
+
+(prin1 (macroexpand-all '(lambda () (test x))
+                        '((test . (lambda (x) (test x))))))
+(write-byte ?\n)

src/base.c

@@ -282,8 +282,8 @@ static void check_handler_bind_handlers(LispVal *handlers) {
         CHECK_TYPE(XCDR(handler), TYPE_FUNCTION);
         if (LISTP(XCAR(handler))) {
             // make sure each condition is a symbol
-            DOTAILS(rest, XCAR(handler)) {
+            DOLIST_SAFE(e, XCAR(handler)) {
-                CHECK_TYPE(XCAR(rest), TYPE_SYMBOL);
+                CHECK_TYPE(e, TYPE_SYMBOL);
             }
         } else if (!SYMBOLP(XCAR(handler))) {
             // if the condition is not a list or symbol, it's an error

src/base.h

@@ -1,5 +1,5 @@
-#ifndef INCLUDED_TYPES_H
+#ifndef INCLUDED_BASE_H
-#define INCLUDED_TYPES_H
+#define INCLUDED_BASE_H
 
 #include "argcountmacro.h"
 #include "gc.h"

src/function.c

@@ -235,21 +235,6 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void),
 }
 
 // Calling functions
-static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) {
-    LispVal *start = Qnil;
-    LispVal *end = NULL;
-    DOLIST(arg, args) {
-        if (NILP(start)) {
-            start = CONS(Feval(arg, Vlexical_environment), Qnil);
-            end = start;
-        } else {
-            RPLACD(end, CONS(Feval(arg, Vlexical_environment), Qnil));
-            end = XCDR(end);
-        }
-    }
-    return start;
-}
-
 enum ProcessArgsResult {
     PROCESS_ARGS_OK,
     PROCESS_ARGS_TOO_FEW,
@@ -334,13 +319,7 @@ static noreturn void signal_argument_error(enum ProcessArgsResult res) {
     lisp_signal(Qargument_error, LIST(msg));
 }
 
-static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
+static ALWAYS_INLINE LispVal *call_native(LispFunction *fobj, LispVal *args) {
-                                          LispFunction *fobj, LispVal *args) {
-    StackFrame *stack_ref = LISP_STACK_REF();
-    if (!fobj->impl.native.no_eval_args) {
-        args = evaluate_function_arguments(args);
-    }
-    set_stack_evaluated_args(LISP_STACK_REF(), fobj, args);
     LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS] = {NULL};
     size_t count = NATIVE_FUNCTION_TOTAL_ARG_COUNT(fobj);
     intptr_t rest_idx;
@@ -381,7 +360,7 @@ static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
     default:
         abort();
     }
-    return UNWIND_AND_RETURN(stack_ref, retval);
+    return retval;
 }
 
 static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec,
@@ -455,21 +434,17 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) {
     return PROCESS_ARGS_OK;
 }
 
-static ALWAYS_INLINE LispVal *
+static ALWAYS_INLINE LispVal *call_interpreted(LispFunction *fobj,
-call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
+                                               LispVal *args) {
-    StackFrame *stack_ref = LISP_STACK_REF();
-    LispVal *evaled_args = evaluate_function_arguments(args);
-    set_stack_evaluated_args(LISP_STACK_REF(), fobj, evaled_args);
     push_dynamic_binding(Qlexical_environment, fobj->impl.interp.lexenv);
-    enum ProcessArgsResult par =
+    enum ProcessArgsResult par = push_interpreted_args_to_lexenv(fobj, args);
-        push_interpreted_args_to_lexenv(fobj, evaled_args);
     if (par != PROCESS_ARGS_OK) {
         signal_argument_error(par);
     }
-    return UNWIND_AND_RETURN(stack_ref, Fprogn(fobj->impl.interp.body));
+    return Fprogn(fobj->impl.interp.body);
 }
 
-static LispFunction *coerce_to_function(LispVal *func) {
+LispFunction *coerce_to_function(LispVal *orig_name, LispVal *func) {
     LispFunction *fobj = func;
     if (SYMBOLP(func)) {
         fobj = Fsymbol_function(func, Qt);
@@ -477,29 +452,39 @@ static LispFunction *coerce_to_function(LispVal *func) {
         fobj = Feval(func, Vlexical_environment);
     }
     if (NILP(fobj)) {
+        lisp_signal(Qvoid_function_error, LIST(orig_name));
+    } else if (!FUNCTIONP(fobj)) {
         signal_type_error(fobj, LIST(Qcallable));
     }
-    // include symbol here for the error message
-    CHECK_TYPE(fobj, TYPE_FUNCTION, TYPE_SYMBOL);
     assert(FUNCTIONP(fobj));
     return fobj;
 }
 
-DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)",
+LispVal *raw_funcall(LispVal *func, LispVal *args) {
-      "") {
+    assert(FUNCTIONP(func));
-    StackFrame *stack_ref = LISP_STACK_REF();
+    LispFunction *fobj = func;
-    push_call_frame(func, args);
-    LispFunction *fobj = coerce_to_function(func);
     switch (fobj->type) {
     case FUNCTION_NATIVE:
-        return UNWIND_AND_RETURN(stack_ref, call_native(func, fobj, args));
+        return call_native(fobj, args);
     case FUNCTION_INTERP:
-        return UNWIND_AND_RETURN(stack_ref, call_interpreted(func, fobj, args));
+        return call_interpreted(fobj, args);
     default:
         abort();
     }
 }
 
+DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)",
+      "") {
+    LispVal *res = coerce_to_function(func, func);
+    if (!NILP(Fspecial_form_p(res))) {
+        signal_type_error(res, Qfunction);
+    }
+    StackFrame *stack_ref = LISP_STACK_REF();
+    push_call_frame(func, args);
+    set_stack_evaluated_args(LISP_STACK_REF(), res, args);
+    return UNWIND_AND_RETURN(stack_ref, raw_funcall(res, args));
+}
+
 static LispVal *parse_lambda_declare_form(LispFunction *fobj, LispVal *body) {
     while (CONSP(body) && CONSP(XCAR(body)) && EQ(XCAR(XCAR(body)), Qdeclare)) {
         LispVal *decls = XCDR(XCAR(body));
@@ -519,6 +504,18 @@ static LispVal *parse_lambda_declare_form(LispFunction *fobj, LispVal *body) {
     return body;
 }
 
+static void macroexpand_lambda_list(struct LambdaList *restrict ll) {
+    DOLIST(ent, ll->opt) {
+        RPLACA(XCDR(ent), Fmacroexpand_all(SECOND(ent), Qnil));
+    }
+    if (HASH_TABLE_P(ll->kw)) {
+        HT_FOREACH_INDEX(ll->kw, i) {
+            LispVal *ent = HASH_VALUE(ll->kw, i);
+            RPLACA(XCDR(XCDR(ent)), Fmacroexpand_all(THIRD(ent), Qnil));
+        }
+    }
+}
+
 DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body),
            "(args &rest body)", "") {
     LambdaListParseResult llpr;
@@ -542,7 +539,8 @@ DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body),
         fobj->docstr = Qnil;
     }
     body = parse_lambda_declare_form(fobj, body);
-    fobj->impl.interp.body = body;
+    macroexpand_lambda_list(&fobj->args);
+    fobj->impl.interp.body = macroexpand_list(body, Qnil);
     fobj->impl.interp.lexenv = Vlexical_environment;
     return fobj;
 }
@@ -556,8 +554,9 @@ DEFUN(callablep, "callablep", (LispVal * obj), "(obj)", "") {
 }
 
 DEFUN(function_arity, "function-arity", (LispVal * func), "(func)",
-      "Return a list of the form (NUM-REQ NUM-OPT KW-NAMES HAS-REST).") {
+      "Return a list of the form (NUM-REQ NUM-OPT KW-NAMES ALLOW-OTHER-KEYS "
-    LispFunction *fobj = coerce_to_function(func);
+      "HAS-REST).") {
+    LispFunction *fobj = coerce_to_function(func, func);
     LispVal *kw = Qnil;
     if (HASH_TABLE_P(fobj->args.kw)) {
         HT_FOREACH_INDEX(fobj->args.kw, i) {
@@ -565,7 +564,28 @@ DEFUN(function_arity, "function-arity", (LispVal * func), "(func)",
         }
     }
     return LIST(MAKE_FIXNUM(fobj->args.n_req), MAKE_FIXNUM(fobj->args.n_opt),
-                kw, NILP(fobj->args.rest) ? Qnil : Qt);
+                kw, fobj->args.allow_other_keys ? Qt : Qnil,
+                NILP(fobj->args.rest) ? Qnil : Qt);
+}
+
+bool builtin_function_p(LispVal *val, bool special_form) {
+    if (SYMBOLP(val)) {
+        val = Fsymbol_function(val, Qt);
+    }
+    if (FUNCTIONP(val)) {
+        LispFunction *fobj = val;
+        return fobj->type == FUNCTION_NATIVE
+               && fobj->impl.native.no_eval_args == special_form;
+    }
+    return false;
+}
+
+DEFUN(builtin_function_p, "builtin-function-p", (LispVal * val), "(val)", "") {
+    return builtin_function_p(val, false) ? Qt : Qnil;
+}
+
+DEFUN(special_form_p, "special-form-p", (LispVal * val), "(val)", "") {
+    return builtin_function_p(val, true) ? Qt : Qnil;
 }
 
 DEFINE_SYMBOL(declare, "declare");
@@ -574,6 +594,8 @@ DEFINE_SYMBOL(name, "name");
 DEFINE_SYMBOL(callable, "callable");
 DEFINE_SYMBOL(argument_error, "argument-error");
 DEFINE_CONDITION_CLASS(argument_error, error);
+DEFINE_SYMBOL(void_function_error, "void-function-error");
+DEFINE_CONDITION_CLASS(void_function_error, error);
 
 DEFINE_SYMBOL(function_definition_error, "function-definition-error");
 DEFINE_CONDITION_CLASS(function_definition_error, error);

src/function.h

@@ -89,6 +89,9 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(void),
         make_lisp_string(internal_F##cname##_docstr,                \
                          internal_F##cname##_docstr_len, false, false))
 
+LispFunction *coerce_to_function(LispVal *orig_name, LispVal *func);
+// Call a function object directly
+LispVal *raw_funcall(LispVal *func, LispVal *args);
 DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args));
 #define CALL(func, ...) (Ffuncall((func), LIST(__VA_ARGS__)))
 #define CALL0(func)     (Ffuncall((func), Qnil))
@@ -97,12 +100,18 @@ DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
 DECLARE_FUNCTION(callablep, (LispVal * obj));
 DECLARE_FUNCTION(function_arity, (LispVal * func));
 
+bool builtin_function_p(LispVal *val, bool special_form);
+DECLARE_FUNCTION(builtin_function_p, (LispVal * val));
+DECLARE_FUNCTION(special_form_p, (LispVal * val));
+
 DECLARE_SYMBOL(declare);
 DECLARE_SYMBOL(name);
 
 DECLARE_SYMBOL(callable);
 DECLARE_SYMBOL(argument_error);
 MAKE_CONDITION_CLASS(argument_error);
+DECLARE_SYMBOL(void_function_error);
+MAKE_CONDITION_CLASS(void_function_error);
 
 DECLARE_SYMBOL(function_definition_error);
 MAKE_CONDITION_CLASS(function_definition_error);

src/gen-init-globals.awk

@@ -72,7 +72,7 @@ function get_next_symbol() {
 function maybe_emit_next_symbol(entity) {
     name = get_next_symbol()
     if (name) {
-        print "    REGISTER_GLOBAL_" entity "(" get_next_symbol() ");";
+        print "    REGISTER_GLOBAL_" entity "(" name ");";
     }
 }
 

src/lisp.c

@@ -84,6 +84,22 @@ static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) {
     return SYMBOL_VALUE(name);
 }
 
+static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args,
+                                                          LispVal *lexenv) {
+    LispVal *start = Qnil;
+    LispVal *end = NULL;
+    DOLIST(arg, args) {
+        if (NILP(start)) {
+            start = CONS(Feval(arg, lexenv), Qnil);
+            end = start;
+        } else {
+            RPLACD(end, CONS(Feval(arg, lexenv), Qnil));
+            end = XCDR(end);
+        }
+    }
+    return start;
+}
+
 DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
       "(form &optional lexenv)", "") {
     if (!OBJECTP(form)) {
@@ -109,8 +125,24 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
     }
     case TYPE_SYMBOL:
         return lookup_variable(form, lexenv);
-    case TYPE_CONS:
+    case TYPE_CONS: {
-        return Ffuncall(XCAR(form), XCDR(form));
+        LispVal *res = XCAR(form);
+        if (SYMBOLP(res)) {
+            res = Fsymbol_function(res, Qt);
+        }
+        if (!NILP(Fmacrop(res))) {
+            return Feval(Fmacroexpand_all(form, Qnil), lexenv);
+        }
+        LispVal *stack_ref = LISP_STACK_REF();
+        push_call_frame(XCAR(form), XCDR(form));
+        LispVal *evaled_args = XCDR(form);
+        if (NILP(Fspecial_form_p(res))) {
+            evaled_args = evaluate_function_arguments(XCDR(form), lexenv);
+        }
+        LispVal *fobj = coerce_to_function(XCAR(form), res);
+        set_stack_evaluated_args(LISP_STACK_REF(), fobj, evaled_args);
+        return UNWIND_AND_RETURN(stack_ref, raw_funcall(fobj, evaled_args));
+    }
     case TYPE_FIXNUM:
     case TYPE_FLOAT:
     default:

src/lisp.h

@@ -6,6 +6,7 @@
 #include "hashtable.h" // IWYU pragma: export
 #include "lisp_string.h" // IWYU pragma: export
 #include "list.h" // IWYU pragma: export
+#include "macro.h" // IWYU pragma: export
 #include "print.h" // IWYU pragma: export
 #include "stack.h" // IWYU pragma: export
 

src/list.c

@@ -35,6 +35,16 @@ DEFUN(cons, "cons", (LispVal * car, LispVal *cdr), "(car cdr)",
     return CONS(car, cdr);
 }
 
+DEFUN(car, "car", (LispVal * list), "(list)", "") {
+    CHECK_LISTP(list);
+    return NILP(list) ? Qnil : XCAR(list);
+}
+
+DEFUN(cdr, "cdr", (LispVal * list), "(list)", "") {
+    CHECK_LISTP(list);
+    return NILP(list) ? Qnil : XCDR(list);
+}
+
 DEFUN(length, "length", (LispVal * list), "(list)", "") {
     CHECK_LISTP(list);
     intptr_t len = list_length(list);
@@ -96,11 +106,30 @@ DEFUN(list, "list", (LispVal * args), "(&rest args)", "") {
     return args;
 }
 
+DEFUN(copy_list, "copy-list", (LispVal * list), "(list)", "") {
+    LispVal *start = Qnil;
+    LispVal *end = NULL;
+    DOTAILS(rest, list) {
+        if (!CONSP(rest)) {
+            RPLACD(end, rest);
+            break;
+        }
+        if (NILP(start)) {
+            start = CONS(XCAR(rest), Qnil);
+            end = start;
+        } else {
+            RPLACD(end, CONS(XCAR(rest), Qnil));
+            end = XCDR(end);
+        }
+    }
+    return start;
+}
+
 LispVal *nth(size_t n, LispVal *list) {
     size_t i = 0;
-    DOTAILS(rest, list) {
+    DOLIST_SAFE(elt, list) {
         if (i == n) {
-            return XCAR(rest);
+            return elt;
         }
         ++i;
     }
@@ -117,12 +146,14 @@ DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred),
     if (NILP(pred) || pred == Qeq) {
         // fast case
         DOTAILS(rest, list) {
+            CHECK_LISTP(rest);
             if (elt == XCAR(rest)) {
                 return rest;
             }
         }
     } else {
         DOTAILS(rest, list) {
+            CHECK_LISTP(rest);
             if (!NILP(CALL(pred, elt, XCAR(rest)))) {
                 return rest;
             }
@@ -134,6 +165,7 @@ DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred),
 DEFUN(member_if, "member-if", (LispVal * pred, LispVal *list), "(pred list)",
       "") {
     DOTAILS(rest, list) {
+        CHECK_LISTP(rest);
         if (!NILP(CALL(pred, XCAR(rest)))) {
             return rest;
         }
@@ -145,7 +177,9 @@ DEFUN(plist_put, "plist-put", (LispVal * plist, LispVal *prop, LispVal *value),
       "(plist prop value)", "") {
     CHECK_LISTP(plist);
     DOTAILS(rest, plist) {
+        CHECK_LISTP(rest);
         if (EQ(XCAR(rest), prop)) {
+            CHECK_TYPE(XCDR(rest), TYPE_CONS);
             RPLACA(XCDR(rest), value);
             return plist;
         }
@@ -163,3 +197,24 @@ DEFUN(plist_get, "plist-get", (LispVal * plist, LispVal *prop, LispVal *def),
     }
     return def;
 }
+
+DEFUN(assoc, "assoc", (LispVal * key, LispVal *alist, LispVal *pred),
+      "(key alist &optional pred)", "") {
+    if (NILP(pred)) {
+        DOLIST_SAFE(ent, alist) {
+            CHECK_TYPE(ent, TYPE_CONS);
+            if (EQ(key, XCAR(ent))) {
+                return ent;
+            }
+        }
+        return Qnil;
+    } else {
+        DOLIST_SAFE(ent, alist) {
+            CHECK_TYPE(ent, TYPE_CONS);
+            if (!NILP(CALL(pred, key, XCAR(ent)))) {
+                return ent;
+            }
+        }
+        return Qnil;
+    }
+}

src/list.h

@@ -106,6 +106,10 @@ static ALWAYS_INLINE LispVal *LIST_N(int count, ...) {
     for (LispVal *_tail = (l), *v = XCAR(_tail); !NILP(_tail); \
          _tail = XCDR(_tail), v = XCAR(_tail))
 
+#define DOLIST_SAFE(v, l)                                      \
+    for (LispVal *_tail = (l), *v = Fcar(_tail); !NILP(_tail); \
+         _tail = Fcdr(_tail), v = Fcar(_tail))
+
 #define DOTAILS(v, l) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v))
 
 DECLARE_SYMBOL(circular_list_error);
@@ -117,6 +121,8 @@ intptr_t list_length(LispVal *list);
 bool list_length_eq(LispVal *list, intptr_t size);
 
 DECLARE_FUNCTION(cons, (LispVal * car, LispVal *cdr));
+DECLARE_FUNCTION(car, (LispVal * list));
+DECLARE_FUNCTION(cdr, (LispVal * list));
 DECLARE_FUNCTION(length, (LispVal * list));
 DECLARE_FUNCTION(length_eq, (LispVal * list, LispVal *length));
 DECLARE_FUNCTION(nreverse, (LispVal * list));
@@ -126,6 +132,7 @@ DECLARE_FUNCTION(proper_list_p, (LispVal * obj));
 DECLARE_FUNCTION(circular_list_p, (LispVal * obj));
 DECLARE_FUNCTION(dotted_list_p, (LispVal * obj));
 DECLARE_FUNCTION(list, (LispVal * args));
+DECLARE_FUNCTION(copy_list, (LispVal * list));
 LispVal *nth(size_t n, LispVal *list);
 DECLARE_FUNCTION(nth, (LispVal * n, LispVal *list));
 static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) {
@@ -141,4 +148,6 @@ DECLARE_FUNCTION(member_if, (LispVal * pred, LispVal *list));
 DECLARE_FUNCTION(plist_put, (LispVal * plist, LispVal *prop, LispVal *value));
 DECLARE_FUNCTION(plist_get, (LispVal * plist, LispVal *prop, LispVal *def));
 
+DECLARE_FUNCTION(assoc, (LispVal * key, LispVal *alist, LispVal *pred));
+
 #endif

src/macro.c

@@ -0,0 +1,162 @@
+#include "macro.h"
+
+#include "function.h"
+#include "lisp.h"
+#include "list.h"
+
+DEFINE_SYMBOL(macro, "macro");
+
+DEFUN(macrop, "macrop", (LispVal * obj), "(obj)", "") {
+    if (SYMBOLP(obj)) {
+        obj = Fsymbol_function(obj, Qt);
+    }
+    if (CONSP(obj) && EQ(XCAR(obj), Qmacro) && !NILP(Fcallablep(XCDR(obj)))) {
+        return XCDR(obj);
+    }
+    return Qnil;
+}
+
+static LispVal *resolve_macro(LispVal *sym_or_list, LispVal *lexical_macros) {
+    if (SYMBOLP(sym_or_list)) {
+        LispVal *lexical_entry = Fassoc(sym_or_list, lexical_macros, Qnil);
+        if (CONSP(lexical_entry)) {
+            return XCDR(lexical_entry);
+        }
+    }
+    return Fmacrop(sym_or_list);
+}
+
+DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form, LispVal *lexical_macros),
+      "(form &optional lexical-macros)", "") {
+    CHECK_LISTP(form);
+    if (NILP(form)) {
+        return Qnil;
+    }
+    LispVal *func = resolve_macro(XCAR(form), lexical_macros);
+    if (NILP(func)) {
+        return form;
+    }
+    return Ffuncall(func, XCDR(form));
+}
+
+DEFUN(macroexpand_toplevel, "macroexpand-toplevel",
+      (LispVal * form, LispVal *lexical_macros),
+      "(form &optional lexical-macros)", "") {
+    while (CONSP(form)
+           && (!NILP(Fmacrop(XCAR(form)))
+               || !NILP(Fassoc(XCAR(form), lexical_macros, Qnil)))) {
+        form = Fmacroexpand_1(form, lexical_macros);
+    }
+    return form;
+}
+
+LispVal *macroexpand_list(LispVal *list, LispVal *lexical_macros) {
+    LispVal *start = Qnil;
+    LispVal *end = NULL;
+    DOTAILS(rest, list) {
+        if (!LISTP(rest)) {
+            RPLACD(end, rest);
+            break;
+        }
+        LispVal *expanded = Fmacroexpand_all(XCAR(rest), lexical_macros);
+        if (NILP(start)) {
+            start = CONS(expanded, Qnil);
+            end = start;
+        } else {
+            RPLACD(end, CONS(expanded, Qnil));
+            end = XCDR(end);
+        }
+    }
+    return start;
+}
+
+static LispVal *macroexpand_lambda_form(LispVal *form,
+                                        LispVal *lexical_macros) {
+    LispVal *body = macroexpand_list(XCDR_SAFE(XCDR(form)), lexical_macros);
+    LispVal *lambda_list = Fcopy_list(XCAR_SAFE(XCDR(form)));
+    enum { REQ, OPT, KEY } state = REQ;
+    DOTAILS(rest, XCAR_SAFE(XCDR(form))) {
+        if (!CONSP(rest)) {
+            break;
+        }
+        LispVal *ent = XCAR(rest);
+        if (state == REQ && EQ(ent, Qand_optional)) {
+            state = OPT;
+        } else if (state == OPT && EQ(ent, Qand_key)) {
+            state = KEY;
+        } else if ((state == KEY || state == OPT) && CONSP(ent)
+                   && CONSP(XCDR(ent))) {
+            ent = Fcopy_list(ent);
+            RPLACA(rest, ent);
+            RPLACA(XCDR(ent), Fmacroexpand_all(SECOND(ent), lexical_macros));
+        }
+    }
+    return CONS(XCAR(form), CONS(lambda_list, body));
+}
+
+static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form,
+                                         LispVal *lexical_macros) {
+    assert(FUNCTIONP(fobj));
+#define IS(n) (fobj == ((LispSymbol *) Q##n)->function)
+    if (IS(lambda)) {
+        return macroexpand_lambda_form(form, lexical_macros);
+    } else if (IS(quote)) {
+        return form;
+    } else if (IS(progn) || IS(if) || IS(and) || IS(or)) {
+        if (LISTP(XCDR(form))) {
+            return CONS(XCAR(form),
+                        macroexpand_list(XCDR(form), lexical_macros));
+        }
+        return form;
+    } else if (IS(setq)) {
+        LispVal *args = Fcopy_list(XCDR(form));
+        bool expand = false;
+        DOTAILS(rest, args) {
+            if (expand) {
+                RPLACA(rest, Fmacroexpand_all(XCAR(rest), lexical_macros));
+            }
+            expand = !expand;
+        }
+        return CONS(XCAR(form), args);
+    } else if (IS(let)) {
+        LispVal *bindings = Fcopy_list(SECOND(form));
+        DOTAILS(rest, bindings) {
+            if (!LISTP(rest)) {
+                break;
+            }
+            LispVal *binding = XCAR(rest);
+            if (CONSP(binding) && CONSP(XCDR(binding))) {
+                RPLACA(XCDR(binding),
+                       Fmacroexpand_all(SECOND(binding), lexical_macros));
+            }
+        }
+        LispVal *prog =
+            macroexpand_list(XCDR_SAFE(XCDR_SAFE(form)), lexical_macros);
+        return CONS(XCAR(form), CONS(bindings, prog));
+    }
+    abort();
+#undef IS
+}
+
+DEFUN(macroexpand_all, "macroexpand-all",
+      (LispVal * form, LispVal *lexical_macros),
+      "(form &optional lexical-macros)", "") {
+    if (!CONSP(form)) {
+        return form;
+    }
+    LispVal *func = XCAR(form);
+    if (SYMBOLP(func)) {
+        func = Fsymbol_function(func, Qt);
+    }
+    if (builtin_function_p(func, true)) {
+        return macroexpand_special_form(func, form, lexical_macros);
+    } else {
+        form = Fmacroexpand_toplevel(form, lexical_macros);
+        if (CONSP(form) && CONSP(XCDR(form))) {
+            return CONS(XCAR(form),
+                        macroexpand_list(XCDR(form), lexical_macros));
+        }
+        return form;
+    }
+    return Qnil;
+}

src/macro.h

@@ -0,0 +1,15 @@
+#ifndef INCLUDED_MACRO_H
+#define INCLUDED_MACRO_H
+
+#include "base.h"
+
+DECLARE_SYMBOL(macro);
+
+DECLARE_FUNCTION(macrop, (LispVal * obj));
+DECLARE_FUNCTION(macroexpand_1, (LispVal * form, LispVal *lexical_macros));
+DECLARE_FUNCTION(macroexpand_toplevel,
+                 (LispVal * form, LispVal *lexical_macros));
+LispVal *macroexpand_list(LispVal *list, LispVal *lexical_macros);
+DECLARE_FUNCTION(macroexpand_all, (LispVal * form, LispVal *lexical_macros));
+
+#endif

src/print.c

@@ -349,7 +349,11 @@ static void print_function(struct PrintContext *restrict pc, LispVal *val) {
     print_char(pc, '<');
     switch (f->type) {
     case FUNCTION_NATIVE:
+        if (f->impl.native.no_eval_args) {
+            PRINT_STATIC_BUFFER(pc, "special-form");
+        } else {
             PRINT_STATIC_BUFFER(pc, "native-function");
+        }
         break;
     case FUNCTION_INTERP:
         PRINT_STATIC_BUFFER(pc, "interp-function");
@@ -358,6 +362,10 @@ static void print_function(struct PrintContext *restrict pc, LispVal *val) {
         abort();
     }
     print_char(pc, ' ');
+    if (!NILP(f->name)) {
+        print_driver(pc, f->name);
+        print_char(pc, ' ');
+    }
     // large enough for 32 or 64 bit word size
     char buffer[32];
     int written = snprintf(buffer, sizeof(buffer), "0x%jx", (uintmax_t) &f);