Re: [PATCH] Implement local-eval, local-compile, and the-environment

[Mark H Weaver]

Here's an improved version of the patch.  Most notably, I removed the
`#:to' parameter to `local-compile', since I realized it couldn't be
implemented properly anyway.  I also updated the copyright notices to
2012 in all changed files, and made some other simplifications and
cleanups.

    Best,
     Mark


>From a8b587cd9c25d4e1a999e870190edf472561f8f2 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Tue, 3 Jan 2012 04:02:08 -0500
Subject: [PATCH] Implement `local-eval', `local-compile', and
 `the-environment'

* module/ice-9/local-eval.scm: New module (ice-9 local-eval) which
  exports `local-eval' and `local-compile'.  This module also contains
  (non-exported) syntax transformers used internally by psyntax to
  implement `the-environment'.

* module/ice-9/psyntax.scm: New core syntax form `the-environment'.
  New internal procedure `reachable-bindings' generates the list
  of lexical bindings reachable using normal symbols (as opposed to
  syntax objects which could reach a larger set of bindings).

* libguile/debug.c (scm_local_eval): New C function that calls the
  Scheme implementation of `local-eval' in (ice-9 local-eval).

* libguile/debug.h (scm_local_eval): Add prototype.

* doc/ref/api-evaluation.texi (Local Evaluation): Add documentation.

* test-suite/tests/eval.test (local evaluation): Add tests.

* test-suite/standalone/test-loose-ends.c (test_scm_local_eval):
  Add test.

* module/Makefile.am: Add ice-9/local-eval.scm.

* module/ice-9/psyntax-pp.scm: Regenerate from psyntax.scm.
---
 doc/ref/api-evaluation.texi             |   41 +-
 libguile/debug.c                        |   13 +-
 libguile/debug.h                        |    4 +-
 module/Makefile.am                      |    5 +-
 module/ice-9/local-eval.scm             |  108 +
 module/ice-9/psyntax-pp.scm             |23191 ++++++++++++++++---------------
 module/ice-9/psyntax.scm                |  107 +-
 test-suite/standalone/test-loose-ends.c |   16 +-
 test-suite/tests/eval.test              |   68 +-
 9 files changed, 12126 insertions(+), 11427 deletions(-)
 create mode 100644 module/ice-9/local-eval.scm

diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 6a09bef..bd2f5c1 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 
2006, 2009, 2010, 2011
address@hidden Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 
2006, 2009, 2010, 2011, 2012
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -19,6 +19,7 @@ loading, evaluating, and compiling Scheme code at run time.
 * Loading::                     Loading Scheme code from file.
 * Character Encoding of Source Files:: Loading non-ASCII Scheme code from file.
 * Delayed Evaluation::          Postponing evaluation until it is needed.
+* Local Evaluation::            Evaluation in a local lexical environment.
 @end menu
 
 
@@ -952,6 +953,44 @@ value.
 @end deffn
 
 
address@hidden Local Evaluation
address@hidden Local Evaluation
+
address@hidden syntax the-environment
+Captures and returns a lexical environment for use with
address@hidden or @code{local-compile}.
address@hidden deffn
+
address@hidden {Scheme Procedure} local-eval exp env
address@hidden {C Function} scm_local_eval (exp, env)
+Evaluate the expression @var{exp} in the lexical environment @var{env}.
+This mostly behaves as if @var{exp} had been wrapped in a lambda
+expression @code{`(lambda () ,@var{exp})} and put in place of
address@hidden(the-environment)}, with the resulting procedure called by
address@hidden  In other words, @var{exp} is evaluated within the
+lexical environment of @code{(the-environment)}, but within the dynamic
+environment of the call to @code{local-eval}.
address@hidden deffn
+
address@hidden {Scheme Procedure} local-compile exp env [opts=()]
+Compile the expression @var{exp} in the lexical environment @var{env}.
+If @var{exp} is a procedure, the result will be a compiled procedure;
+otherwise @code{local-compile} is mostly equivalent to
address@hidden  @var{opts} specifies the compilation options.
address@hidden deffn
+
+Note that the current implementation of @code{(the-environment)} has
+some limitations.  It does not capture local syntax transformers bound
+by @code{let-syntax}, @code{letrec-syntax} or non-top-level
address@hidden forms.  It also does not capture pattern variables
+bound by @code{syntax-case}.  Any attempt to reference such captured
+bindings via @code{local-eval} or @code{local-compile} produces an
+error.  Finally, @code{(the-environment)} does not capture lexical
+bindings that are shadowed by inner bindings with the same name, nor
+hidden lexical bindings produced by macro expansion, even though such
+bindings might be accessible using syntax objects.
+
+
 @c Local Variables:
 @c TeX-master: "guile.texi"
 @c End:
diff --git a/libguile/debug.c b/libguile/debug.c
index 88a01d6..d41acc4 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -1,5 +1,5 @@
 /* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 
2009, 2010, 2011 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 
2009, 2010, 2011, 2012 Free Software Foundation
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -208,6 +208,17 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
 #undef FUNC_NAME
 #endif
 
+SCM
+scm_local_eval (SCM exp, SCM env)
+{
+  static SCM local_eval_var = SCM_BOOL_F;
+
+  if (scm_is_false (local_eval_var))
+    local_eval_var = scm_c_module_lookup
+      (scm_c_resolve_module ("ice-9 local-eval"), "local-eval");
+  return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env);
+}
+
 static void
 init_stack_limit (void)
 {
diff --git a/libguile/debug.h b/libguile/debug.h
index d862aba..4155d19 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -3,7 +3,7 @@
 #ifndef SCM_DEBUG_H
 #define SCM_DEBUG_H
 
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2012
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -41,6 +41,8 @@ typedef union scm_t_debug_info
 
 
 
+SCM_API SCM scm_local_eval (SCM exp, SCM env);
+
 SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
 SCM_API SCM scm_procedure_source (SCM proc);
 SCM_API SCM scm_procedure_name (SCM proc);
diff --git a/module/Makefile.am b/module/Makefile.am
index 56fa48d..9c9d8ed 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -1,6 +1,6 @@
 ## Process this file with automake to produce Makefile.in.
 ##
-##     Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+##     Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -243,7 +243,8 @@ ICE_9_SOURCES = \
   ice-9/weak-vector.scm \
   ice-9/list.scm \
   ice-9/serialize.scm \
-  ice-9/vlist.scm
+  ice-9/vlist.scm \
+  ice-9/local-eval.scm
 
 SRFI_SOURCES = \
   srfi/srfi-1.scm \
diff --git a/module/ice-9/local-eval.scm b/module/ice-9/local-eval.scm
new file mode 100644
index 0000000..c028443
--- /dev/null
+++ b/module/ice-9/local-eval.scm
@@ -0,0 +1,108 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2012 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+(define-module (ice-9 local-eval)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (system base compile)
+  #:export (local-eval local-compile))
+
+(define-record-type lexical-environment-type
+  (make-lexical-environment wrapper names boxes others module-name)
+  lexical-environment?
+  (wrapper     lexenv-wrapper)
+  (names       lexenv-names)
+  (boxes       lexenv-boxes)
+  (others      lexenv-others)
+  (module-name lexenv-module-name))
+
+(set-record-type-printer!
+ lexical-environment-type
+ (lambda (e port)
+   (format port "#<lexical-environment ~S ~S ~S>"
+          (lexenv-module-name e)
+          (map (lambda (name box) (list name (box)))
+               (lexenv-names e) (lexenv-boxes e))
+          (lexenv-others e))))
+
+(define (local-eval x e)
+  (cond ((lexical-environment? e)
+        (apply (eval ((lexenv-wrapper e) x)
+                     (resolve-module (lexenv-module-name e)))
+               (lexenv-boxes e)))
+       ((module? e) (eval x e))
+       (else (error "local-eval: invalid lexical environment" e))))
+
+(define* (local-compile x e #:key (opts '()))
+  (cond ((lexical-environment? e)
+        (apply (compile ((lexenv-wrapper e) x)
+                        #:env (resolve-module (lexenv-module-name e))
+                        #:from 'scheme #:opts opts)
+               (lexenv-boxes e)))
+       ((module? e) (compile x #:env e #:from 'scheme #:opts opts))
+       (else (error "local-compile: invalid lexical environment" e))))
+
+(define-syntax-rule (box v)
+  (case-lambda
+   (() v)
+   ((x) (set! v x))))
+
+(define-syntax-rule (box-lambda* (v ...) (other ...) e)
+  (lambda (v ...)
+    (let-syntax
+       ((v (identifier-syntax-from-box v))
+        ...
+        (other (unsupported-binding 'other))
+        ...)
+      (if #t e))))
+
+(define-syntax-rule (capture-environment
+                    module-name (v ...) (b ...) (other ...))
+  (make-lexical-environment
+   (lambda (expression) #`(box-lambda*
+                          #,'(v ...)
+                          #,'(other ...)
+                          #,expression))
+   '(v ...)
+   (list b ...)
+   '(other ...)
+   'module-name))
+
+(define-syntax-rule (identifier-syntax-from-box b)
+  (make-transformer-from-box
+   (syntax-object-of b)
+   (identifier-syntax (id          (b))
+                     ((set! id x) (b x)))))
+
+(define-syntax syntax-object-of
+  (lambda (form)
+    (syntax-case form ()
+      ((_ x) #`(quote #,(datum->syntax #'x #'x))))))
+
+(define (make-transformer-from-box id trans)
+  (set-procedure-property! trans 'identifier-syntax-box id)
+  trans)
+
+(define (unsupported-binding name)
+  (make-variable-transformer
+   (lambda (x)
+     (syntax-violation
+      name
+      "unsupported binding captured by (the-environment)"
+      x))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 4fec917..0f92144 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1,6 +1,6 @@
 ;;;; -*-scheme-*-
 ;;;;
-;;;;   Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011 Free Software 
Foundation, Inc.
+;;;;   Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011, 2012 Free Software 
Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -784,6 +784,55 @@
                       id))))))
          (else (syntax-violation 'id-var-name "invalid id" id)))))
 
+    ;;
+    ;; reachable-bindings returns an alist containing one entry
+    ;; (sym . label) for each binding that is accessible using normal
+    ;; symbols.
+    ;;
+    ;; This implementation was derived from that of id-var-name (above),
+    ;; and closely mirrors its structure.
+    ;;
+    (define reachable-bindings
+      (lambda (w)
+        (define scan
+          (lambda (subst marks results)
+            (if (null? subst)
+                results
+                (let ((fst (car subst)))
+                  (if (eq? fst 'shift)
+                      (scan (cdr subst) (cdr marks) results)
+                      (let ((symnames (ribcage-symnames fst)))
+                        (if (vector? symnames)
+                            (scan-vector-rib subst marks symnames fst results)
+                            (scan-list-rib subst marks symnames fst 
results))))))))
+        (define scan-list-rib
+          (lambda (subst marks symnames ribcage results)
+            (let f ((symnames symnames) (i 0) (results results))
+              (cond
+               ((null? symnames) (scan (cdr subst) marks results))
+               ((and (not (assq (car symnames) results))
+                     (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+                (f (cdr symnames)
+                   (fx+ i 1)
+                   (cons (cons (car symnames)
+                               (list-ref (ribcage-labels ribcage) i))
+                         results)))
+               (else (f (cdr symnames) (fx+ i 1) results))))))
+        (define scan-vector-rib
+          (lambda (subst marks symnames ribcage results)
+            (let ((n (vector-length symnames)))
+              (let f ((i 0) (results results))
+                (cond
+                 ((fx= i n) (scan (cdr subst) marks results))
+                 ((and (not (assq (vector-ref symnames i) results))
+                       (same-marks? marks (vector-ref (ribcage-marks ribcage) 
i)))
+                  (f (fx+ i 1)
+                     (cons (cons (vector-ref symnames i)
+                                 (vector-ref (ribcage-labels ribcage) i))
+                           results)))
+                 (else (f (fx+ i 1) results)))))))
+        (scan (wrap-subst w) (wrap-marks w) '())))
+
     ;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
     ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
 
@@ -1791,6 +1840,62 @@
                        (_ (syntax-violation 'quote "bad syntax"
                                             (source-wrap e w s mod))))))
 
+    (global-extend 'core 'the-environment
+                   (lambda (e r w s mod)
+                     (define ice-9-local-eval
+                       (lambda (sym)
+                         (wrap sym top-wrap '(private ice-9 local-eval))))
+                     (define gen-capture-params
+                       (lambda ()
+                         (let loop ((sym+labels (reachable-bindings w))
+                                    (vars '()) (boxes '()) (others '()))
+                           (if (null? sym+labels)
+                               (values vars boxes others)
+                               (let* ((id   (wrap   (caar sym+labels) w mod))
+                                      (b    (lookup (cdar sym+labels) r mod))
+                                      (type (binding-type b)))
+                                   (cond
+                                    ((eq? type 'lexical)
+                                     (loop (cdr sym+labels)
+                                           (cons id vars)
+                                           (cons `(,(ice-9-local-eval 'box) 
,id)
+                                                 boxes)
+                                           others))
+                                    ((and (eq? type 'macro)
+                                          (procedure-property (binding-value b)
+                                                              
'identifier-syntax-box))
+                                     => (lambda (box)
+                                          (loop (cdr sym+labels)
+                                                (cons id vars)
+                                                (cons box boxes)
+                                                others)))
+                                    ;;
+                                    ;; ENHANCE-ME: Handle more types of local 
macros.  At
+                                    ;; the very least, it should be possible 
to handle
+                                    ;; local syntax-rules macros, by saving 
the macro body
+                                    ;; in a procedure-property of the 
transformer, and
+                                    ;; then wrapping the local expression 
within an
+                                    ;; equivalent set of nested let-syntax and
+                                    ;; letrec-syntax forms (replacing the 
current flat
+                                    ;; let-syntax generated by box-lambda*).  
In practice,
+                                    ;; most syntax-case macros could be 
handled this way
+                                    ;; too, although the emulation would not 
be perfect,
+                                    ;; e.g. in cases when the transformer 
contains local
+                                    ;; state.
+                                    ;;
+                                    (else (loop (cdr sym+labels)
+                                                vars boxes (cons id 
others)))))))))
+                     (syntax-case e ()
+                       ((_)
+                        (call-with-values
+                            (lambda () (gen-capture-params))
+                          (lambda (vars boxes others)
+                            (expand `(,(ice-9-local-eval 'capture-environment)
+                                      ,(cdr mod) ,vars ,boxes ,others)
+                                    r empty-wrap mod))))
+                       (_ (syntax-violation 'the-environment "bad syntax"
+                                            (source-wrap e w s mod))))))
+
     (global-extend 'core 'syntax
                    (let ()
                      (define gen-syntax
diff --git a/test-suite/standalone/test-loose-ends.c 
b/test-suite/standalone/test-loose-ends.c
index 2fdbe7d..52f524b 100644
--- a/test-suite/standalone/test-loose-ends.c
+++ b/test-suite/standalone/test-loose-ends.c
@@ -3,7 +3,7 @@
  * Test items of the Guile C API that aren't covered by any other tests.
  */
 
-/* Copyright (C) 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2012 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -43,9 +43,23 @@ test_scm_from_locale_keywordn ()
 }
 
 static void
+test_scm_local_eval ()
+{
+  SCM result = scm_local_eval
+    (scm_list_3 (scm_from_latin1_symbol ("+"),
+                scm_from_latin1_symbol ("x"),
+                scm_from_latin1_symbol ("y")),
+     scm_c_eval_string ("(let ((x 1) (y 2)) (the-environment))"));
+     
+  assert (scm_is_true (scm_equal_p (result,
+                                   scm_from_signed_integer (3))));
+}
+
+static void
 tests (void *data, int argc, char **argv)
 {
   test_scm_from_locale_keywordn ();
+  test_scm_local_eval ();
 }
 
 int
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index a128cd7..8b3319a 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -1,5 +1,5 @@
 ;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011 Free Software 
Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free 
Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,7 +19,8 @@
   :use-module (test-suite lib)
   :use-module ((srfi srfi-1) :select (unfold count))
   :use-module ((system vm vm) :select (make-vm call-with-vm))
-  :use-module (ice-9 documentation))
+  :use-module (ice-9 documentation)
+  :use-module (ice-9 local-eval))
 
 
 (define exception:bad-expression
@@ -422,4 +423,67 @@
           (thunk (let loop () (cons 's (loop)))))
       (call-with-vm vm thunk))))
 
+;;;
+;;; local-eval
+;;;
+
+(with-test-prefix "local evaluation"
+
+  (pass-if "local-eval"
+
+    (let* ((env1 (let ((x 1) (y 2) (z 3))
+                   (define-syntax-rule (foo x) (quote x))
+                   (the-environment)))
+           (env2 (local-eval '(let ((x 111) (a 'a))
+                                (define-syntax-rule (bar x) (quote x))
+                                (the-environment))
+                           env1)))
+      (local-eval '(set! x 11) env1)
+      (local-eval '(set! y 22) env1)
+      (local-eval '(set! z 33) env2)
+      (and (equal? (local-eval '(list x y z) env1)
+                   '(11 22 33))
+           (equal? (local-eval '(list x y z a) env2)
+                   '(111 22 33 a)))))
+
+  (pass-if "local-compile"
+
+    (let* ((env1 (let ((x 1) (y 2) (z 3))
+                   (define-syntax-rule (foo x) (quote x))
+                   (the-environment)))
+           (env2 (local-compile '(let ((x 111) (a 'a))
+                                   (define-syntax-rule (bar x) (quote x))
+                                   (the-environment))
+                                env1)))
+      (local-compile '(set! x 11) env1)
+      (local-compile '(set! y 22) env1)
+      (local-compile '(set! z 33) env2)
+      (and (equal? (local-compile '(list x y z) env1)
+                   '(11 22 33))
+           (equal? (local-compile '(list x y z a) env2)
+                   '(111 22 33 a)))))
+
+  (pass-if "mixed primitive-eval, local-eval and local-compile"
+
+    (let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3))
+                                    (define-syntax-rule (foo x) (quote x))
+                                    (the-environment))))
+           (env2 (local-eval '(let ((x 111) (a 'a))
+                                (define-syntax-rule (bar x) (quote x))
+                                (the-environment))
+                             env1))
+           (env3 (local-compile '(let ((y 222) (b 'b))
+                                   (the-environment))
+                                env2)))
+      (local-eval    '(set! x 11) env1)
+      (local-compile '(set! y 22) env2)
+      (local-eval    '(set! z 33) env2)
+      (local-compile '(set! a (* y 2)) env3)
+      (and (equal? (local-compile '(list x y z) env1)
+                   '(11 22 33))
+           (equal? (local-eval '(list x y z a) env2)
+                   '(111 22 33 444))
+           (equal? (local-eval '(list x y z a b) env3)
+                   '(111 222 33 444 b))))))
+
 ;;; eval.test ends here
-- 
1.7.5.4