From 66edcf5b3241cecad795f4043f4f08ce45f2ca12 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sun, 25 Mar 2018 21:04:50 -0700 Subject: 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. --- eval.c | 9 +++++++++ share/txr/stdlib/compiler.tl | 5 +++++ 2 files changed, 14 insertions(+) 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" -- cgit v1.2.3