Add capture-env to evaluator

* libguile/eval.c (eval):
* libguile/memoize.c (memoized_tags, unmemoize):
* libguile/memoize.h (SCM_M_CAPTURE_ENV):
* module/ice-9/eval.scm (primitive-eval): Add capture-env memoized
  expression type.

4 files changed, 40 insertions, 1 deletions

diff --git a/libguile/eval.c b/libguile/eval.c
index d76fbd30d..9f0955748 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -280,6 +280,28 @@ eval (SCM x, SCM env)
     case SCM_M_LAMBDA:
       RETURN_BOOT_CLOSURE (mx, env);
 
+    case SCM_M_CAPTURE_ENV:
+      {
+        SCM locs = CAR (mx);
+        SCM new_env;
+        int i;
+
+        new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
+        for (i = 0; i < VECTOR_LENGTH (locs); i++)
+          {
+            SCM loc = VECTOR_REF (locs, i);
+            int depth, width;
+
+            depth = SCM_I_INUM (CAR (loc));
+            width = SCM_I_INUM (CDR (loc));
+            env_set (new_env, 0, i, env_ref (env, depth, width));
+          }
+
+        env = new_env;
+        x = CDR (mx);
+        goto loop;
+      }
+
     case SCM_M_QUOTE:
       return mx;
 
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 9651cadc6..3923ee334 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -165,6 +165,7 @@ static const char *const memoized_tags[] =
   "seq",
   "if",
   "lambda",
+  "capture-env",
   "let",
   "quote",
   "define",
@@ -625,6 +626,10 @@ unmemoize (const SCM expr)
 			 tail));
 	  }
       }
+    case SCM_M_CAPTURE_ENV:
+      return scm_list_3 (scm_from_latin1_symbol ("capture-env"),
+                         CAR (args),
+                         unmemoize (CDR (args)));
     case SCM_M_LET:
       return scm_list_3 (scm_sym_let,
                          unmemoize_bindings (CAR (args)),
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 68dcd2167..f0dab5797 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -3,7 +3,7 @@
 #ifndef SCM_MEMOIZE_H
 #define SCM_MEMOIZE_H
 
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2013
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2013,2014
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -66,6 +66,7 @@ enum
     SCM_M_SEQ,
     SCM_M_IF,
     SCM_M_LAMBDA,
+    SCM_M_CAPTURE_ENV,
     SCM_M_LET,
     SCM_M_QUOTE,
     SCM_M_DEFINE,
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 98db033ea..aa1ab2e0a 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -499,6 +499,17 @@
                (lp (cdr meta))))
            proc))
 
+        (('capture-env (locs . body))
+         (let* ((len (vector-length locs))
+                (new-env (make-env len #f (env-toplevel env))))
+           (let lp ((n 0))
+             (when (< n len)
+               (mx-bind
+                (vector-ref locs n) (depth . width)
+                (env-set! new-env 0 n (env-ref env depth width)))
+               (lp (1+ n))))
+           (eval body new-env)))
+
         (('seq (head . tail))
          (begin
            (eval head env)