compiler: implement defmacro special op.

* share/txr/stdlib/compiler.tl (compiler compile): Handle
defmacro via expand-defmacro expander.
(expand-defmacro): New function.

1 files changed, 14 insertions, 0 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index d35b5e7d..48a9f22d 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -197,6 +197,7 @@
             (dwim me.(comp-dwim oreg env form))
             (defvarl me.(compile oreg env (expand-defvarl form)))
             (defun me.(compile oreg env (expand-defun form)))
+            (defmacro me.(compile oreg env (expand-defmacro form)))
             (sys:upenv me.(compile oreg env.up (cadr form)))
             (sys:dvbind me.(compile oreg env (caddr form)))
             (sys:with-dyn-rebinds me.(comp-progn oreg env (cddr form)))
@@ -1097,6 +1098,19 @@
                              name))))
         (t (compile-error form "~s isn't a valid function name" name))))))
 
+(defun expand-defmacro (form)
+  (mac-param-bind form (op name mac-args . body) form
+    (with-gensyms (form menv)
+      (let ((exp-lam ^(lambda (,form ,menv)
+                        (mac-param-bind ,form ,mac-args (cdr ,form)
+                          (sys:set-macro-ancestor
+                            (block ,name
+                              ,*body)
+                            ,form)))))
+        ^(progn
+           (sys:rt-defmacro ',name '(macro ,name) ,exp-lam)
+           ',name)))))
+
 (defun sys:bind-mac-error (ctx-form params obj too-few-p)
   (if (atom obj)
     (compile-error ctx-form "extra atom ~s not matched by params ~s"