compiler: implement defsymacro special op.

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

* eval.c (rt_defsymacro): New static function.
(eval_init): register sys:rt-defsymacro intrinsic.

2 files changed, 14 insertions, 0 deletions

diff --git a/eval.c b/eval.c
index c2a7bb67..4007f51d 100644
--- a/eval.c
+++ b/eval.c
@@ -1844,6 +1844,14 @@ static val op_defsymacro(val form, val env)
   return sym;
 }
 
+static val rt_defsymacro(val sym, val def)
+{
+  remhash(top_vb, sym);
+  remhash(special, sym);
+  sethash(top_smb, sym, cons(sym, def));
+  return sym;
+}
+
 static val op_defmacro(val form, val env);
 
 void trace_check(val name)
@@ -6626,6 +6634,7 @@ void eval_init(void)
   reg_fun(intern(lit("rt-defvarl"), system_package), func_n1(rt_defvarl));
   reg_fun(intern(lit("rt-defun"), system_package), func_n2(rt_defun));
   reg_fun(intern(lit("rt-defmacro"), system_package), func_n3(rt_defmacro));
+  reg_fun(intern(lit("rt-defsymacro"), system_package), func_n2(rt_defsymacro));
 
   eval_error_s = intern(lit("eval-error"), user_package);
   uw_register_subtype(eval_error_s, error_s);
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 48a9f22d..f2614f77 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -198,6 +198,7 @@
             (defvarl me.(compile oreg env (expand-defvarl form)))
             (defun me.(compile oreg env (expand-defun form)))
             (defmacro me.(compile oreg env (expand-defmacro form)))
+            (defsymacro me.(compile oreg env (expand-defsymacro 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)))
@@ -1111,6 +1112,10 @@
            (sys:rt-defmacro ',name '(macro ,name) ,exp-lam)
            ',name)))))
 
+(defun expand-defsymacro (form)
+  (mac-param-bind form (op name def) form
+    ^(sys:rt-defsymacro ',name ',def)))
+
 (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"