[PATCH] Implement `the-environment' and `local-eval' in evaluator

[Mark H Weaver]

Here's an improved version of the preliminary evaluator-only
implementation of `the-environment' and `local-eval'.  I renamed the
primitives to the Guile 1.8 names, fixed the expansion within
`local-eval' to use `expand' instead of `expand-top-sequence', made the
module handling more robust, and various other minor improvements.

I plan to fully support these primitives in the compiler as well, in a
future version of this patch.

This is still a _preliminary_ patch.  In particular:

* The compiler currently fails ungracefully if it encounters
  (the-environment).

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

* I still wouldn't be surprised if `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.72-c6748
  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-syntax ((foo 
(syntax-rules () ((foo x) (quote x))))) (let ((x 1) (y 2)) (the-environment)))))
  scheme@(guile-user)> (local-eval 'x env1)
  $1 = 1
  scheme@(guile-user)> (local-eval 'y env1)
  $2 = 2
  scheme@(guile-user)> (local-eval '(foo (1 2)) env1)
  $3 = (1 2)
  scheme@(guile-user)> (define env2 (local-eval '(let-syntax ((bar 
(syntax-rules () ((bar x) (foo x))))) (let ((x 1) (z 3)) (the-environment))) 
env1))
  scheme@(guile-user)> (local-eval 'x env2)
  $4 = 1
  scheme@(guile-user)> (local-eval '(bar (1 2)) env2)
  $5 = (1 2)
  scheme@(guile-user)> (local-eval '(foo (1 2)) env2)
  $6 = (1 2)
  scheme@(guile-user)> (local-eval 'z env2)
  $7 = 3
  scheme@(guile-user)> (local-eval '(set! x (+ x 10)) env2)
  $8 = 11
  scheme@(guile-user)> (local-eval 'x env1)
  $9 = 1

      Mark


>From c6748349a833cd61b380259ca8b9d81d7f14128f 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 `the-environment' and `local-eval' 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       |   31 +
 module/ice-9/psyntax-pp.scm |23299 ++++++++++++++++++++++---------------------
 module/ice-9/psyntax.scm    |   26 +-
 module/language/tree-il.scm |    8 +
 8 files changed, 12095 insertions(+), 11310 deletions(-)

diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index c0fa64c..7d6e6c1 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -213,6 +213,8 @@
 ;;; `eval' in this order, to put the most frequent cases first.
 ;;;
 
+(define local-eval #f)  ;; This is set! from within the primitive-eval block
+
 (define primitive-eval
   (let ()
     ;; We pre-generate procedures with fixed arities, up to some number of
@@ -357,6 +359,14 @@
                                            ;; Finally, eval the body.
                                            (eval body env)))))))))))))))
 
+    ;; FIXME: make this opaque!!
+    (define (make-lexical-environment module eval-env memoizer-env 
expander-env)
+      (list '<lexical-environment> module eval-env memoizer-env expander-env))
+    (define lexical-environment:module cadr)
+    (define lexical-environment:eval-env caddr)
+    (define lexical-environment:memoizer-env cadddr)
+    (define (lexical-environment:expander-env env) (car (cddddr env)))
+
     ;; The "engine". EXP is a memoized expression.
     (define (eval exp env)
       (memoized-expression-case exp
@@ -459,6 +469,12 @@
                   (eval exp env)
                   (eval handler env)))
         
+        (('the-environment (memoizer-env . expander-env))
+         (let ((module (capture-env (if (pair? env)
+                                        (cdr (last-pair env))
+                                        env))))
+           (make-lexical-environment module env memoizer-env expander-env)))
+
         (('call/cc proc)
          (call/cc (eval proc env)))
 
@@ -468,6 +484,21 @@
               var-or-spec
               (memoize-variable-access! exp #f))
           (eval x env)))))
+
+    (set! local-eval
+          (lambda (exp env)
+            "Evaluate @var{exp} within the lexical environment @var{env}."
+            (let ((module (lexical-environment:module env))
+                  (eval-env (lexical-environment:eval-env env))
+                  (memoizer-env (lexical-environment:memoizer-env env))
+                  (expander-env (lexical-environment:expander-env env)))
+              (eval (memoize-local-expression
+                     (if (macroexpanded? exp)
+                         exp
+                         ((module-transformer module)
+                          exp #:env expander-env))
+                     memoizer-env)
+                    eval-env))))
   
     ;; primitive-eval
     (lambda (exp)
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 26bd5b1..f012d3a 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_the_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_THE_ENVIRONMENT
   };
 
 
 
 
 SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
+SCM_INTERNAL SCM scm_memoize_local_expression (SCM exp, SCM memoizer_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/memoize.c b/libguile/memoize.c
index 911d972..f7be46e 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_THE_ENVIRONMENT(memoizer_env, expander_env)    \
+  MAKMEMO (SCM_M_THE_ENVIRONMENT, scm_cons(memoizer_env, expander_env))
 
 
 /* Primitives for the evaluator */
@@ -143,6 +145,7 @@ static const char *const memoized_tags[] =
   "module-ref",
   "module-set!",
   "prompt",
+  "the-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_THE_ENVIRONMENT:
+      return MAKMEMO_THE_ENVIRONMENT (env, REF (exp, THE_ENVIRONMENT, 
EXPANDER_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 memoizer_env),
+           "Memoize the expression @var{exp} within @var{memoizer_env}.")
+#define FUNC_NAME s_scm_memoize_local_expression
+{
+  SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
+  return memoize (exp, memoizer_env);
+}
+#undef FUNC_NAME
+
 
 
 
@@ -706,6 +722,8 @@ unmemoize (const SCM expr)
                          unmemoize (CAR (args)),
                          unmemoize (CADR (args)),
                          unmemoize (CDDR (args)));
+    case SCM_M_THE_ENVIRONMENT:
+      return scm_list_3 (scm_sym_the_environment, CAR (args), CDR (args));
     default:
       abort ();
     }
diff --git a/libguile/expand.h b/libguile/expand.h
index 02e6e17..b150058 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_THE_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_THE_ENVIRONMENT_TYPE_NAME "the-environment"
+#define SCM_EXPANDED_THE_ENVIRONMENT_FIELD_NAMES  \
+  { "src", "expander-env", }
+enum
+  {
+    SCM_EXPANDED_THE_ENVIRONMENT_SRC,
+    SCM_EXPANDED_THE_ENVIRONMENT_EXPANDER_ENV,
+    SCM_NUM_EXPANDED_THE_ENVIRONMENT_FIELDS,
+  };
+#define SCM_MAKE_EXPANDED_THE_ENVIRONMENT(src, expander_env)           \
+  scm_c_make_struct (exp_vtables[SCM_EXPANDED_THE_ENVIRONMENT], 0, 
SCM_NUM_EXPANDED_THE_ENVIRONMENT_FIELDS, SCM_UNPACK (src), SCM_UNPACK 
(expander_env))
+
 #endif /* BUILDING_LIBGUILE */
 
 
diff --git a/libguile/expand.c b/libguile/expand.c
index bdecd80..18d9e40 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 THE_ENVIRONMENT(src, expander_env)     \
+  SCM_MAKE_EXPANDED_THE_ENVIRONMENT(src, expander_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_the_environment, "the-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 (THE_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..907cc82 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -49,6 +49,7 @@
             <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
+            <the-environment> the-environment? make-the-environment 
the-environment-src the-environment-expander-env
             <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 +126,7 @@
   ;; (<let> names gensyms vals body)
   ;; (<letrec> in-order? names gensyms vals body)
   ;; (<dynlet> fluids vals body)
+  ;; (<the-environment> expander-env)
 
 (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
   (<fix> names gensyms vals body)
@@ -324,6 +326,9 @@
     ((<dynset> fluid exp)
      `(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
 
+    ((<the-environment> expander-env)
+     `(the-environment ,expander-env))
+
     ((<prompt> tag body handler)
      `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il 
handler)))
 
@@ -470,6 +475,9 @@
     ((<dynset> fluid exp)
      `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp)))
 
+    ((<the-environment>)
+     '(the-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..292f932 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-the-environment src expander-env)
+      (make-the-environment src expander-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 'the-environment
+                   (lambda (e r w s mod)
+                     (syntax-case e ()
+                       ((_) (build-the-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,9 +2413,11 @@
     ;; 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)
+            (if env
+                (expand x (psyntax-env:r env) (psyntax-env:w env) 
(psyntax-env:mod env))
+                (expand-top-sequence (list x) null-env top-wrap #f m esew
+                                     (cons 'hygiene (module-name 
(current-module)))))))
 
     (set! identifier?
           (lambda (x)
-- 
1.7.5.4