compiler: implement defun special op.

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

1 files changed, 20 insertions, 0 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 57da0219..d35b5e7d 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -196,6 +196,7 @@
             (sys:lisp1-value me.(comp-lisp1-value oreg env form))
             (dwim me.(comp-dwim oreg env form))
             (defvarl me.(compile oreg env (expand-defvarl form)))
+            (defun me.(compile oreg env (expand-defun 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)))
@@ -1077,6 +1078,25 @@
            (usr:rplacd ,cell (cons ',sym ,value)))
          ',sym))))
 
+(defun expand-defun (form)
+  (mac-param-bind form (op name args . body) form
+    (flet ((mklambda (block-name)
+             ^(lambda ,args (block ,block-name ,*body))))
+      (cond
+        ((bindable name)
+         ^(sys:rt-defun ',name ,(mklambda name)))
+        ((consp name)
+         (caseq (car name)
+           (meth
+             (mac-param-bind form (meth type slot) name
+               ^(sys:define-method ',type ',slot ,(mklambda slot))))
+           (macro
+             (mac-param-bind form (macro sym) name
+               ^(sys:rt-defmacro ',sym ',name ,(mklambda sym))))
+           (t (compile-error form "~s isn't a valid compound function name"
+                             name))))
+        (t (compile-error form "~s isn't a valid function name" 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"