compiler: implement sys:setqf special op.

* share/txr/stdlib/compiler.tl (compiler compile): Handle
sys:setqf via comp-setqf.
(compiler comp-setqf): New method.

1 files changed, 17 insertions, 0 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 406253a5..71c0df4d 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -171,6 +171,7 @@
             (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))
+            (sys:setqf me.(comp-setqf 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))
@@ -256,6 +257,22 @@
                       vfrag.ffuns))))
         (t me.(compile oreg env ^(sys:setq ,sym ,val)))))))
 
+(defmeth compiler comp-setqf (me oreg env form)
+  (mac-param-bind form (op sym val) form
+    (if env.(lookup-fun sym)
+      (compile-error form "assignment to lexical function binding")
+      (let ((vfrag me.(compile oreg env val))
+            (fname me.(get-dreg sym))
+            (rplcd me.(get-fidx 'usr:rplacd))
+            (treg me.(alloc-treg)))
+        me.(free-treg treg)
+        (new (frag vfrag.oreg
+                   ^(,*vfrag.code
+                      (getfb ,treg ,fname)
+                      (gcall ,treg ,rplcd ,treg ,vfrag.oreg))
+                   (uni (list sym) vfrag.fvars)
+                   vfrag.ffuns))))))
+
 (defmeth compiler comp-cond (me oreg env form)
   (let* ((lout (gensym "l"))
          (raw-cases (rest form))