compile: handle functions that have environments.

With this patch, the compile function can handle interpreted
function objects that have captured environments.

For instance, if the following expression is evaluated

  (let ((counter 0))
    (labels ((bm () (bump))
             (bump () (inc counter)))
      (lambda () (bm))))

then a function object emerges. We can now feed this
function object to the compile function; the environment
will now be handled.

Of course, the above expression is already compileable;
compile-toplevel handles it and so does the file compiler.

This patch allows the expression to be interpreted and then
the function object to be compiled, without access to the
surrounding expression. The compiled function will contain a
compiled version of the environment, carrying compiled
versions of the captured variables and their contents.

* eval.c (env_vbindings, env_fbindings, env_next): New static
functions.
(eval_init): Register env-vbinding, env-fbindings and env-next
intrinsics.

* share/txr/stdlib/compiler.tl (sys:env-to-let): New function.
(usr:compile): Wrap the interpreted lambda terms with let
bindings carefully reconstructed from their captured
environments.

* txr.1: Documented new intrinsic functions.

1 files changed, 31 insertions, 2 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 51b0becd..2f27365d 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1682,16 +1682,45 @@
               (error "~s: compilation of ~s failed" 'compile-file
                      (stream-get-prop in-stream :name)))))))))
 
+(defun sys:env-to-let (env form)
+  (when env
+    (let ((vb (env-vbindings env))
+          (fb (env-fbindings env))
+          (up (env-next env)))
+      (when vb
+        (set form ^(let ,(mapcar (tb ((a . d)) ^(,a ',d)) vb) ,form)))
+      (when fb
+        (let (lbind fbind)
+          (each ((pair fb))
+            (tree-bind (a . d) pair
+              (let* ((fun-p (interp-fun-p d))
+                     (fe (if fun-p (func-get-env d)))
+                     (lb-p (and fe (eq fe env)))
+                     (fb-p (and fe (eq fe up))))
+                (cond
+                  (lb-p (push ^(,a ,(func-get-form d)) lbind))
+                  (fb-p (push ^(,a ,(func-get-form d)) fbind))
+                  (t (push ^(,a ',d) fbind))))))
+          (when lbind
+            (set form ^(sys:lbind ,(nreverse lbind) ,form)))
+          (when fbind
+            (set form ^(sys:fbind ,(nreverse fbind) ,form)))))
+      (if up
+        (set form (sys:env-to-let up form)))))
+  form)
+
 (defun usr:compile (obj)
   (typecase obj
     (fun (tree-bind (indicator args . body) (func-get-form obj)
-           (let* ((form ^(lambda ,args ,*body))
+           (let* ((form (sys:env-to-let (func-get-env obj)
+                                        ^(lambda ,args ,*body)))
                   (vm-desc (compile-toplevel form)))
              (vm-execute-toplevel vm-desc))))
     (t (condlet
          (((fun (symbol-function obj)))
           (tree-bind (indicator args . body) (func-get-form fun)
-            (let* ((form ^(lambda ,args ,*body))
+            (let* ((form (sys:env-to-let (func-get-env fun)
+                                         ^(lambda ,args ,*body)))
                    (vm-desc (compile-toplevel form))
                    (comp-fun (vm-execute-toplevel vm-desc)))
               (set (symbol-function obj) comp-fun))))