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.

3 files changed, 93 insertions, 2 deletions

diff --git a/eval.c b/eval.c
index 6053c853..637ed8a6 100644
--- a/eval.c
+++ b/eval.c
@@ -202,6 +202,27 @@ val env_vbind(val env, val sym, val obj)
   }
 }
 
+static val env_vbindings(val env)
+{
+  val self = lit("env-vbindings");
+  type_check(self, env, ENV);
+  return env->e.vbindings;
+}
+
+static val env_fbindings(val env)
+{
+  val self = lit("env-fbindings");
+  type_check(self, env, ENV);
+  return env->e.fbindings;
+}
+
+static val env_next(val env)
+{
+  val self = lit("env-next");
+  type_check(self, env, ENV);
+  return env->e.up_env;
+}
+
 static void env_vb_to_fb(val env)
 {
   if (env) {
@@ -6499,6 +6520,9 @@ void eval_init(void)
   reg_fun(intern(lit("make-env"), user_package), func_n3o(make_env_intrinsic, 0));
   reg_fun(intern(lit("env-fbind"), user_package), func_n3(env_fbind));
   reg_fun(intern(lit("env-vbind"), user_package), func_n3(env_vbind));
+  reg_fun(intern(lit("env-vbindings"), user_package), func_n1(env_vbindings));
+  reg_fun(intern(lit("env-fbindings"), user_package), func_n1(env_fbindings));
+  reg_fun(intern(lit("env-next"), user_package), func_n1(env_next));
   reg_fun(intern(lit("lexical-var-p"), user_package), func_n2(lexical_var_p));
   reg_fun(intern(lit("lexical-fun-p"), user_package), func_n2(lexical_fun_p));
   reg_fun(intern(lit("lexical-lisp1-binding"), user_package),
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))))
diff --git a/txr.1 b/txr.1
index 1aac81f8..4620b368 100644
--- a/txr.1
+++ b/txr.1
@@ -16435,6 +16435,44 @@ is specified as
 .codn nil ,
 then the binding takes place in the global environment.
 
+.coNP Functions @, env-vbindings @ env-fbindings and @ env-next
+.synb
+.mets (env-vbindings << env )
+.mets (env-fbindings << env )
+.mets (env-next << env )
+.syne
+.desc
+These function retrieve the components of
+.metn env ,
+which must be an environment. The
+.code env-vbindings
+function retrieves the the association list representing variable
+bindings. Similarly, the
+.code env-fbindings
+retrieves the association list of function bindings.
+The
+.code env-next
+function retrieves the next environment, if
+.meta env
+has one, otherwise
+.codn nil .
+
+If
+.code e
+is an environment constructed by the expression
+.codn "(make-env v f n)" ,
+then
+.code "(env-vbindings e)"
+retrieves
+.codn v ,
+.code "(env-fbindings e)"
+retrieves
+.code f
+and
+.code "(env-next e)"
+returns
+.codn n .
+
 .SS* Global Environment
 .coNP Accessors @, symbol-function @ symbol-macro and @ symbol-value
 .synb