[PATCH] Implement `capture-lexical-environment' in evaluator

[Mark H Weaver]

This is a _preliminary_ patch.  In particular:

* The compiler does not yet handle (capture-lexical-environment)
  (which uses a new tree-il type).

* The lexical environment object is currently non-opaque list structure.

* I deliberately avoided reindenting eval.scm so that the non-whitespace
  changes would be evident, to make review easier.

* I wouldn't be surprised if `primitive-local-eval' does the wrong thing
  if (current-module) is different from what it was when the associated
  `primitive-eval' was called.

* I manually removed the psyntax-pp.scm patch from the output of
  git-format-patch (though the header change summary still mentions it),
  since it was so huge.  I guess you'll need to manually regenerate that
  file yourself, since the Makefiles don't do it automatically:

     cd guile/module; make ice-9/psyntax-pp.scm.gen

Here's an example session:

  mhw:~/guile$ meta/guile
  GNU Guile 2.0.3.66-52b7f-dirty
  Copyright (C) 1995-2011 Free Software Foundation, Inc.
  
  Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
  This program is free software, and you are welcome to redistribute it
  under certain conditions; type `,show c' for details.
  
  Enter `,help' for help.
  scheme@(guile-user)> (define env1 (primitive-eval '(let ((x 1) (y 2)) 
(capture-lexical-environment))))
  scheme@(guile-user)> (primitive-local-eval 'x env1)
  $1 = 1
  scheme@(guile-user)> (primitive-local-eval 'y env1)
  $2 = 2
  scheme@(guile-user)> (primitive-local-eval '(set! x (+ x 10)) env1)
  $3 = 11
  scheme@(guile-user)> (primitive-local-eval 'x env1)
  $4 = 11
  scheme@(guile-user)> (define env2 (primitive-local-eval '(begin (set! x (+ x 
1)) (let ((z 3)) (capture-lexical-environment))) env1))
  scheme@(guile-user)> (primitive-local-eval 'z env2)
  $5 = 3
  scheme@(guile-user)> (primitive-local-eval 'x env2)
  $6 = 12
  scheme@(guile-user)> (primitive-local-eval 'y env2)
  $7 = 2
  scheme@(guile-user)> (primitive-local-eval 'x env1)
  $8 = 12
  scheme@(guile-user)> (primitive-local-eval '(set! x (+ x 10)) env1)
  $9 = 22
  scheme@(guile-user)> (primitive-local-eval 'x env2)
  $10 = 22
  scheme@(guile-user)> (primitive-local-eval '(set! y (+ y 5)) env2)
  $11 = 7
  scheme@(guile-user)> (primitive-local-eval 'y env1)
  $12 = 7
  scheme@(guile-user)> (define foo 35)
  scheme@(guile-user)> (primitive-local-eval 'foo env1)
  $13 = 35
  scheme@(guile-user)> (primitive-local-eval '(set! foo 37) env1)
  scheme@(guile-user)> foo
  $14 = 37

The preliminary patch follows.  Comments solicited.

     Mark


>From 417762cbd3d299bb166ac240bc84fcceeb6dcde9 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Wed, 14 Dec 2011 03:12:43 -0500
Subject: [PATCH] Implement `capture-lexical-environment' in evaluator

PRELIMINARY WORK, not ready for commit.
---
 libguile/expand.c           |    5 +
 libguile/expand.h           |   13 +
 libguile/memoize.c          |   18 +
 libguile/memoize.h          |    5 +-
 module/ice-9/eval.scm       |   49 +-
 module/ice-9/psyntax-pp.scm |23314 ++++++++++++++++++++++---------------------
 module/ice-9/psyntax.scm    |   32 +-
 module/language/tree-il.scm |   10 +
 8 files changed, 12127 insertions(+), 11319 deletions(-)

diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index c0fa64c..e51c662 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -213,7 +213,16 @@
 ;;; `eval' in this order, to put the most frequent cases first.
 ;;;
 
-(define primitive-eval
+;; FIXME: make this opaque!!
+(define (make-lexical-environment eval-env memo-env expander-env)
+  (list '<lexical-environment> eval-env memo-env expander-env))
+(define lexical-environment:eval-env cadr)
+(define lexical-environment:memo-env caddr)
+(define lexical-environment:expander-env cadddr)
+
+(define primitive-eval #f)
+(define primitive-local-eval #f)
+
   (let ()
     ;; We pre-generate procedures with fixed arities, up to some number of
     ;; arguments; see make-fixed-closure above.
@@ -459,6 +468,9 @@
                   (eval exp env)
                   (eval handler env)))
         
+        (('capture-lexical-environment (memo-env . expander-env))
+         (make-lexical-environment env memo-env expander-env))
+
         (('call/cc proc)
          (call/cc (eval proc env)))
 
@@ -469,12 +481,29 @@
               (memoize-variable-access! exp #f))
           (eval x env)))))
   
-    ;; primitive-eval
-    (lambda (exp)
-      "Evaluate @var{exp} in the current module."
-      (eval 
-       (memoize-expression 
-        (if (macroexpanded? exp)
-            exp
-            ((module-transformer (current-module)) exp)))
-       '()))))
+    (set! primitive-local-eval
+          (lambda (exp env)
+            "Evaluate @var{exp} within the lexical environment @var{env}."
+            (let ((eval-env (lexical-environment:eval-env env))
+                  (memo-env (lexical-environment:memo-env env))
+                  (expander-env (lexical-environment:expander-env env)))
+              (let ((module (capture-env (if (pair? eval-env)
+                                             (cdr (last-pair eval-env))
+                                             eval-env))))
+                (eval
+                 (memoize-local-expression
+                  (if (macroexpanded? exp)
+                      exp
+                      ((module-transformer module) exp #:env expander-env))
+                  memo-env)
+                 eval-env)))))
+
+    (set! primitive-eval
+          (lambda (exp)
+            "Evaluate @var{exp} in the current module."
+            (eval
+             (memoize-expression
+              (if (macroexpanded? exp)
+                  exp
+                  ((module-transformer (current-module)) exp)))
+             '()))))
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 911d972..c06d593 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -112,6 +112,8 @@ scm_t_bits scm_tc16_memoized;
   MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, 
public))))
 #define MAKMEMO_PROMPT(tag, exp, handler) \
   MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
+#define MAKMEMO_CAPTURE_LEXICAL_ENVIRONMENT(memo_env, expander_env)    \
+  MAKMEMO (SCM_M_CAPTURE_LEXICAL_ENVIRONMENT, scm_cons(memo_env, expander_env))
 
 
 /* Primitives for the evaluator */
@@ -143,6 +145,7 @@ static const char *const memoized_tags[] =
   "module-ref",
   "module-set!",
   "prompt",
+  "capture-lexical-environment",
 };
 
 static int
@@ -426,6 +429,9 @@ memoize (SCM exp, SCM env)
                                   memoize_exps (REF (exp, DYNLET, VALS), env),
                                   memoize (REF (exp, DYNLET, BODY), env));
 
+    case SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT:
+      return MAKMEMO_CAPTURE_LEXICAL_ENVIRONMENT (env, REF (exp, 
CAPTURE_LEXICAL_ENVIRONMENT, ENV));
+
     default:
       abort ();
     }
@@ -444,6 +450,16 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 
1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_memoize_local_expression, "memoize-local-expression", 2, 0, 0,
+            (SCM exp, SCM env),
+           "Memoize the expression @var{exp} within the local memoize 
environment @var{env}.")
+#define FUNC_NAME s_scm_memoize_local_expression
+{
+  SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
+  return memoize (exp, env);
+}
+#undef FUNC_NAME
+
 
 
 
@@ -706,6 +722,8 @@ unmemoize (const SCM expr)
                          unmemoize (CAR (args)),
                          unmemoize (CADR (args)),
                          unmemoize (CDDR (args)));
+    case SCM_M_CAPTURE_LEXICAL_ENVIRONMENT:
+      return scm_list_3 (scm_sym_capture_lexical_environment, CAR (args), CDR 
(args));
     default:
       abort ();
     }
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 26bd5b1..4a05bee 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -44,6 +44,7 @@ SCM_API SCM scm_sym_quote;
 SCM_API SCM scm_sym_quasiquote;
 SCM_API SCM scm_sym_unquote;
 SCM_API SCM scm_sym_uq_splicing;
+SCM_API SCM scm_sym_capture_lexical_environment;
 SCM_API SCM scm_sym_with_fluids;
 
 SCM_API SCM scm_sym_at;
@@ -90,13 +91,15 @@ enum
     SCM_M_TOPLEVEL_SET,
     SCM_M_MODULE_REF,
     SCM_M_MODULE_SET,
-    SCM_M_PROMPT
+    SCM_M_PROMPT,
+    SCM_M_CAPTURE_LEXICAL_ENVIRONMENT
   };
 
 
 
 
 SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
+SCM_INTERNAL SCM scm_memoize_local_expression (SCM exp, SCM env);
 SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized);
 SCM_INTERNAL SCM scm_memoized_expression_typecode (SCM memoized);
 SCM_INTERNAL SCM scm_memoized_expression_data (SCM memoized);
diff --git a/libguile/expand.h b/libguile/expand.h
index 02e6e17..b78ef1b 100644
--- a/libguile/expand.h
+++ b/libguile/expand.h
@@ -54,6 +54,7 @@ typedef enum
     SCM_EXPANDED_LET,
     SCM_EXPANDED_LETREC,
     SCM_EXPANDED_DYNLET,
+    SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT,
     SCM_NUM_EXPANDED_TYPES,
   } scm_t_expanded_type;
 
@@ -330,6 +331,18 @@ enum
 #define SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body) \
   scm_c_make_struct (exp_vtables[SCM_EXPANDED_DYNLET], 0, 
SCM_NUM_EXPANDED_DYNLET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (fluids), 
SCM_UNPACK (vals), SCM_UNPACK (body))
 
+#define SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_TYPE_NAME 
"capture-lexical-environment"
+#define SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_FIELD_NAMES  \
+  { "src", "env", }
+enum
+  {
+    SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_SRC,
+    SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_ENV,
+    SCM_NUM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_FIELDS,
+  };
+#define SCM_MAKE_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT(src, env)                
\
+  scm_c_make_struct (exp_vtables[SCM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT], 0, 
SCM_NUM_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT_FIELDS, SCM_UNPACK (src), 
SCM_UNPACK (env))
+
 #endif /* BUILDING_LIBGUILE */
 
 
diff --git a/libguile/expand.c b/libguile/expand.c
index bdecd80..35d1c3a 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -85,6 +85,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
   SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
 #define DYNLET(src, fluids, vals, body) \
   SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
+#define CAPTURE_LEXICAL_ENVIRONMENT(src, env)          \
+  SCM_MAKE_EXPANDED_CAPTURE_LEXICAL_ENVIRONMENT(src, env)
 
 #define CAR(x)   SCM_CAR(x)
 #define CDR(x)   SCM_CDR(x)
@@ -203,6 +205,8 @@ SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
 
+SCM_GLOBAL_SYMBOL (scm_sym_capture_lexical_environment, 
"capture-lexical-environment");
+
 SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
 SCM_KEYWORD (kw_optional, "optional");
 SCM_KEYWORD (kw_key, "key");
@@ -1250,6 +1254,7 @@ scm_init_expand ()
   DEFINE_NAMES (LET);
   DEFINE_NAMES (LETREC);
   DEFINE_NAMES (DYNLET);
+  DEFINE_NAMES (CAPTURE_LEXICAL_ENVIRONMENT);
 
   scm_exp_vtable_vtable =
     scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1d391c4..455dccc 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -49,6 +49,9 @@
             <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals 
dynlet-body
             <dynref> dynref? make-dynref dynref-src dynref-fluid
             <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
+            <capture-lexical-environment> capture-lexical-environment?
+                                          make-capture-lexical-environment
+                                          capture-lexical-environment-src
             <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body 
prompt-handler
             <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
 
@@ -125,6 +128,7 @@
   ;; (<let> names gensyms vals body)
   ;; (<letrec> in-order? names gensyms vals body)
   ;; (<dynlet> fluids vals body)
+  ;; (<capture-lexical-environment>)
 
 (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
   (<fix> names gensyms vals body)
@@ -324,6 +328,9 @@
     ((<dynset> fluid exp)
      `(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
 
+    ((<capture-lexical-environment>)
+     '(capture-lexical-environment))
+
     ((<prompt> tag body handler)
      `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il 
handler)))
 
@@ -470,6 +477,9 @@
     ((<dynset> fluid exp)
      `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp)))
 
+    ((<capture-lexical-environment>)
+     '(capture-lexical-environment))
+
     ((<prompt> tag body handler)
      `(call-with-prompt
        ,(tree-il->scheme tag)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index e522f54..d147902 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -307,6 +307,14 @@
             (if (not (assq 'name meta))
                 (set-lambda-meta! val (acons 'name name meta))))))
 
+    ;; data type for exporting the compile-type environment
+    ;; FIXME: make this opaque!
+    (define (make-psyntax-env r w mod)
+      (list '<psyntax-env> r w mod))
+    (define psyntax-env:r cadr)
+    (define psyntax-env:w caddr)
+    (define psyntax-env:mod cadddr)
+
     ;; output constructors
     (define build-void
       (lambda (source)
@@ -410,6 +418,9 @@
     (define (build-data src exp)
       (make-const src exp))
 
+    (define (build-capture-lexical-environment src env)
+      (make-capture-lexical-environment src env))
+
     (define build-sequence
       (lambda (src exps)
         (if (null? (cdr exps))
@@ -1786,6 +1797,13 @@
                        (_ (syntax-violation 'quote "bad syntax"
                                             (source-wrap e w s mod))))))
 
+    (global-extend 'core 'capture-lexical-environment
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_) (build-capture-lexical-environment s 
(make-psyntax-env r w mod)))
+                       (_ (syntax-violation 'quote "bad syntax"
+                                            (source-wrap e w s mod))))))
+
     (global-extend 'core 'syntax
                    (let ()
                      (define gen-syntax
@@ -2395,10 +2413,17 @@
     ;; expanded, and the expanded definitions are also residualized into
     ;; the object file if we are compiling a file.
     (set! macroexpand
-          (lambda* (x #:optional (m 'e) (esew '(eval)))
-            (expand-top-sequence (list x) null-env top-wrap #f m esew
-                                 (cons 'hygiene (module-name 
(current-module))))))
+          (lambda* (x #:optional (m 'e) (esew '(eval))
+                      #:key (env (make-psyntax-env
+                                  null-env top-wrap
+                                  (cons 'hygiene (module-name 
(current-module))))))
+            (expand-top-sequence (list x)
+                                 (psyntax-env:r env)  ;; null-env
+                                 (psyntax-env:w env)  ;; top-wrap
+                                 #f
+                                 m
+                                 esew
+                                 (psyntax-env:mod env)))) ;; (cons 'hygiene 
(module-name (current-module)))
 
     (set! identifier?
           (lambda (x)
-- 
1.7.5.4