From 4ddec63afdb50cc252bb4396d6cdc0d866c2adfc Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sat, 24 Mar 2018 22:19:33 -0700 Subject: compiler: implement sys:lisp1-setq special op. * share/txr/stdlib/compiler.tl (compiler compile): Handle sys:lisp1-setq via comp-lisp1-setq. (compiler comp-lisp1-setq): New method. --- share/txr/stdlib/compiler.tl | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 7deddcae..3fe8d595 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -170,6 +170,7 @@ (caseq sym (quote me.(comp-atom oreg (cadr form))) (sys:setq me.(comp-setq oreg env form)) + (sys:lisp1-setq me.(comp-lisp1-setq oreg env form)) (cond me.(comp-cond oreg env form)) (if me.(comp-if oreg env form)) (unwind-protect me.(comp-unwind-protect oreg env form)) @@ -239,6 +240,22 @@ (uni (list sym) vfrag.fvars) vfrag.ffuns))))) +(defmeth compiler comp-lisp1-setq (me oreg env form) + (mac-param-bind form (op sym val) form + (let ((bind env.(lookup-lisp1 sym))) + (cond + ((typep bind 'fbinding) + (compile-error form "assignment to lexical function binding")) + ((null bind) + (let ((vfrag me.(compile oreg env val)) + (l1loc me.(get-dreg sym))) + (new (frag l1loc + ^(,*vfrag.code + (setl1 ,vfrag.oreg ,l1loc)) + (uni (list sym) vfrag.fvars) + vfrag.ffuns)))) + (t me.(compile oreg env ^(sys:setq ,sym ,val))))))) + (defmeth compiler comp-cond (me oreg env form) (let* ((lout (gensym "l")) (raw-cases (rest form)) -- cgit v1.2.3