diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-03-24 22:19:33 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-03-24 22:19:33 -0700 |
| commit | 4ddec63afdb50cc252bb4396d6cdc0d866c2adfc (patch) | |
| tree | 2b444a6b76d2a863329203104ebed731f735d212 | |
| parent | ccdc56552dafeed328f43fff5aefff1f9773a3a0 (diff) | |
| download | txr-4ddec63afdb50cc252bb4396d6cdc0d866c2adfc.tar.gz txr-4ddec63afdb50cc252bb4396d6cdc0d866c2adfc.tar.bz2 txr-4ddec63afdb50cc252bb4396d6cdc0d866c2adfc.zip | |
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.
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 17 |
1 files changed, 17 insertions, 0 deletions
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)) |