From ed117784fcb94e20bd68453d8323fab28e5034ba Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sat, 24 Mar 2018 18:05:27 -0700
Subject: compiler: add fbind and lbind special forms

This supports labels and flet.

* share/txr/stdlib/compiler.tl (compiler compile): Route fbind
and lbind to comp-fbind method.
(compiler comp-fbind): New method.
---
 share/txr/stdlib/compiler.tl | 32 ++++++++++++++++++++++++++++++++
 1 file changed, 32 insertions(+)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index d9c89bea..36e2746b 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -166,6 +166,7 @@
             (return-from me.(comp-return-from oreg env form))
             (return me.(comp-return oreg env form))
             ((let let*) me.(comp-let oreg env form))
+            ((sys:fbind sys:lbind) me.(comp-fbind oreg env form))
             (lambda me.(comp-lambda oreg env form))
             (sys:for-op me.(comp-for oreg env form))
             (sys:each-op me.(compile oreg env (expand-each form env)))
@@ -451,6 +452,37 @@
                    (uni (diff bfrag.fvars lexsyms) fvars)
                    (uni ffuns bfrag.ffuns)))))))
 
+(defmeth compiler comp-fbind (me oreg env form)
+  (mac-param-bind form (sym raw-fis . body) form
+    (let* ((fis (mapcar [iffi atom list] raw-fis))
+           (lexfuns [mapcar car fis])
+           (frsize (len lexfuns))
+           (rec (eq sym 'sys:lbind))
+           (nenv (new env up env co me)))
+      (each ((lfun lexfuns))
+        nenv.(extend-fun lfun))
+      (let* (ffuns fvars
+             (code (build
+                     (add ^(frame ,nenv.lev ,frsize))
+                     (each ((fi fis))
+                       (tree-bind (sym : form) fi
+                         (let* ((bind nenv.(lookup-fun sym))
+                                (frag me.(compile bind.loc
+                                                  (if rec nenv env)
+                                                  form)))
+                           (pend frag.code
+                                 (maybe-mov bind.loc frag.oreg))
+                           (set ffuns (uni ffuns frag.ffuns)
+                                fvars (uni fvars frag.fvars)))))))
+             (bfrag me.(comp-progn oreg nenv body))
+             (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg)))
+        (new (frag boreg
+                   (append code bfrag.code
+                           (maybe-mov boreg bfrag.oreg)
+                           ^((end ,boreg)))
+                   (uni fvars bfrag.fvars)
+                   (uni (diff bfrag.ffuns lexfuns) bfrag.ffuns)))))))
+
 (defmeth compiler comp-lambda (me oreg env form)
   (mac-param-bind form (op pars . body) form
     (let* ((rest-par (nthlast 0 pars))
-- 
cgit v1.2.3