[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Implement local-eval, local-compile, and the-environment (v4)
|
From: |
Mark H Weaver |
|
Subject: |
[PATCH] Implement local-eval, local-compile, and the-environment (v4) |
|
Date: |
Sun, 22 Jan 2012 07:23:31 -0500 |
Hello all,
If Andy finishes his version of `local-eval', that's all well and good,
and I'm happy to use his version. However, in case he doesn't have time
to address the remaining issues in his implementation before 2.0.4, or
if he'd like some more time to think about the other new interfaces
before committing them to our API...
I've attached below my latest version of `local-eval', which has the
following advantages:
* Commits us to _no_ new APIs other than `local-eval', `local-compile',
and `the-environment'.
* Does _not_ require universally-unique gensyms, so we could revert that
patch if desired.
* Uses the simple future-proof `evaluator procedure' representation
for lexical environments, allowing even radical changes to the
implementation of `the-environment' while retaining ABI compatibility.
Call me stubborn, but I _still_ think it would be better to use this
implementation in 2.0.4, and to revert both `syntax-local-binding' and
maybe also `universally-unique gensyms' for now. I'm not opposed to
Andy's approach, but I think we need more time to debate the relevant
interfaces. This way, we have complete freedom to do whatever we want
in 2.0.5 and beyond, without making any hasty commitments.
Best,
Mark
>From 496c5ae9f8d8b835dcb9a032447df2f46e2d63bd 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.
---
doc/ref/api-evaluation.texi | 38 ++++++++
libguile/debug.c | 13 +++-
libguile/debug.h | 4 +-
module/Makefile.am | 5 +-
module/ice-9/local-eval.scm | 155 +++++++++++++++++++++++++++++++
module/ice-9/psyntax.scm | 124 ++++++++++++++++++++++++
test-suite/standalone/test-loose-ends.c | 16 +++-
test-suite/tests/eval.test | 92 ++++++++++++++++++-
8 files changed, 440 insertions(+), 7 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 ed3b88c..37cdc2e 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -20,6 +20,7 @@ loading, evaluating, and compiling Scheme code at run time.
* Load Paths:: Where Guile looks for code.
* 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
@@ -987,6 +988,43 @@ 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. Any attempt to reference such captured
+syntactic keywords via @code{local-eval} or @code{local-compile}
+produces an error. Also, @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..0a0b867
--- /dev/null
+++ b/module/ice-9/local-eval.scm
@@ -0,0 +1,155 @@
+;;; -*- 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 version module evaluator)
+ lexical-environment?
+ (version lexenv-version)
+ (module lexenv-module)
+ (evaluator lexenv-evaluator))
+
+(define (lexenv-major-version e) (car (lexenv-version e)))
+(define (lexenv-minor-version e) (cdr (lexenv-version e)))
+
+(set-record-type-printer!
+ lexical-environment-type
+ (lambda (e port)
+ (format port "#<lexical-environment ~S ~S>"
+ (module-name (lexenv-module e))
+ (lexenv-version e))))
+
+(define (local-eval x e)
+ "Evaluate the expression @var{x} within the lexical environment @var{e}."
+ (cond ((lexical-environment? e)
+ (case (lexenv-major-version e)
+ ((1) ((lexenv-evaluator e) x #f))
+ (else (error "local-eval: unsupported lexenv version" e))))
+ ((module? e)
+ ;; Here we evaluate the expression within `lambda', and then
+ ;; call the resulting procedure outside of the dynamic extent
+ ;; of `eval'. We do this because `eval' sets (current-module)
+ ;; within its dynamic extent, and we don't want that. Also,
+ ;; doing it this way makes this a proper tail call.
+ ((eval #`(lambda () #f #,x) e)))
+ (else (error "local-eval: invalid lexical environment" e))))
+
+(define* (local-compile x e #:key (opts '()))
+ "Compile and evaluate the expression @var{x} within the lexical environment
@var{e}."
+ (cond ((lexical-environment? e)
+ (case (lexenv-major-version e)
+ ((1) ((lexenv-evaluator e) x opts))
+ (else (error "local-compile: unsupported lexenv version" e))))
+ ((module? e)
+ ;; Here we compile the expression within `lambda', and then
+ ;; call the resulting procedure outside of the dynamic extent
+ ;; of `compile'. We do this because `compile' sets
+ ;; (current-module) during evaluation, and we don't want that.
+ ((compile #`(lambda () #f #,x)
+ #:env e #:from 'scheme #:opts opts)))
+ (else (error "local-compile: invalid lexical environment" e))))
+
+(define-syntax-rule (make-box v)
+ (case-lambda
+ (() v)
+ ((x) (set! v x))))
+
+(define-syntax box-lambda*
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (v ...) (pvar ...) (pvar-lvl ...) (unsupported ...) e)
+ (with-syntax
+ (((nested-pvar ...)
+ (map within-nested-ellipses #'(pvar ...) #'(pvar-lvl ...))))
+ #'(lambda (v ... pvar ...)
+ (let-syntax
+ ((v (identifier-syntax-from-box v))
+ ...
+ (unsupported (unsupported-binding 'unsupported))
+ ...)
+ (with-syntax
+ ((nested-pvar pvar) ...)
+ #f ; force expression context
+ e))))))))
+
+(define-syntax capture-environment
+ (lambda (x)
+ (syntax-case x ()
+ ((_ module (box ...) (v ...) (pvar ...) (pvar-lvl ...) (unsupported ...))
+ (with-syntax
+ (((nested-pvar ...)
+ (map within-nested-ellipses #'(pvar ...) #'(pvar-lvl ...))))
+ #'(let ((mod module)
+ (args (list box ... #'nested-pvar ...)))
+ (make-lexical-environment
+ '(1 . 0) ; (major . minor) version number
+ mod
+ (lambda (expression opts)
+ (let* ((wrapped-expr (list
+ ;; #'box-lambda* but without the
+ ;; extraneous wrap-subst ribcage
+ (vector 'syntax-object
+ 'box-lambda*
+ '((top))
+ '(hygiene ice-9 local-eval))
+ '(v ...)
+ '(pvar ...)
+ '(pvar-lvl ...)
+ '(unsupported ...)
+ expression))
+ (proc (compile-or-eval wrapped-expr mod opts)))
+ (apply proc args))))))))))
+
+(define-syntax-rule (identifier-syntax-from-box box)
+ (make-transformer-from-box
+ (syntax-object-of box)
+ (identifier-syntax (id (box))
+ ((set! id x) (box 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 (within-nested-ellipses s lvl)
+ (let loop ((s s) (n (syntax->datum lvl)))
+ (if (zero? n) s (loop #`(#,s (... ...))
+ (- n 1)))))
+
+(define (compile-or-eval x mod opts)
+ (if opts
+ (compile x #:env mod #:from 'scheme #:opts opts)
+ (eval x mod)))
+
+(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 fd33e98..1eb3dd3 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -791,6 +791,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) '())))
+
;; Returns three values: binding type, binding value, the module (for
;; resolving toplevel vars).
(define (resolve-identifier id w r mod)
@@ -1844,6 +1893,81 @@
(_ (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))))
+ (call-with-values
+ (lambda ()
+ (syntax-case e ()
+ ((x) (let ((id (wrap #'x w mod)))
+ (values (syntax-object-wrap id)
+ (syntax-object-module id))))
+ (_ (syntax-violation 'the-environment "bad syntax"
+ (source-wrap e w s mod)))))
+ (lambda (w mod)
+ (with-syntax
+ ((make-box (ice-9/local-eval 'make-box))
+ (module-name (cdr mod)))
+ (let* ((sym+labels (reachable-bindings w))
+ (ids (map (lambda (sym+label)
+ (wrap (car sym+label) w
mod))
+ sym+labels))
+ (bindings (map (lambda (sym+label)
+ (lookup (cdr sym+label)
r mod))
+ sym+labels))
+ (categories (map (lambda (id b)
+ (case (binding-type b)
+ ((lexical) 'lexical)
+ ((syntax) 'pattern-var)
+ ((macro) (if
(procedure-property
+
(binding-value b)
+
'identifier-syntax-box)
+
'already-boxed
+ ;; TODO:
support macros
+ #f))
+ (else #f)))
+ ids bindings))
+ (maybe-boxes (map (lambda (id b c)
+ (case c
+ ((lexical) #`(make-box
#,id))
+ ((already-boxed)
(procedure-property
+
(binding-value b)
+
'identifier-syntax-box))
+ (else #f)))
+ ids bindings categories))
+ (maybe-pattern-bindings (map (lambda (b c)
+ (case c
+
((pattern-var) (binding-value b))
+ (else #f)))
+ bindings
categories)))
+ (with-syntax
+ ((capture-environment (ice-9/local-eval
'capture-environment))
+ (module #'(resolve-module 'module-name))
+ (boxes (filter identity maybe-boxes))
+ (var-ids (filter identity (map (lambda
(maybe-box id)
+ (and
maybe-box id))
+ maybe-boxes
ids)))
+ (pattern-var-ids (filter identity
+ (map (lambda
(maybe-pattern-binding id)
+ (and
maybe-pattern-binding id))
+
maybe-pattern-bindings ids)))
+ (pattern-var-lvls (filter identity
+ (map (lambda
(maybe-pattern-binding)
+ (and
maybe-pattern-binding
+ (cdr
maybe-pattern-binding)))
+
maybe-pattern-bindings)))
+ (unsupported-ids (filter identity
+ (map (lambda
(category id)
+ (and (not
category) id))
+ categories
ids))))
+ (expand #`(capture-environment
+ module boxes var-ids
+ pattern-var-ids pattern-var-lvls
+ unsupported-ids)
+ r empty-wrap 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..f815ae2 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..0a587db 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,91 @@
(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 "the-environment within a macro"
+ (let ((module-a-name '(test module the-environment a))
+ (module-b-name '(test module the-environment b)))
+ (let ((module-a (resolve-module module-a-name))
+ (module-b (resolve-module module-b-name)))
+ (module-use! module-a (resolve-interface '(guile)))
+ (module-use! module-a (resolve-interface '(ice-9 local-eval)))
+ (eval '(begin
+ (define z 3)
+ (define-syntax-rule (test)
+ (let ((x 1) (y 2))
+ (the-environment))))
+ module-a)
+ (module-use! module-b (resolve-interface '(guile)))
+ (let ((env (eval `(let ((x 111) (y 222))
+ ((@@ ,module-a-name test)))
+ module-b)))
+ (equal? (local-eval '(list x y z) env)
+ '(1 2 3))))))
+
+ (pass-if "capture pattern variables"
+ (let ((env (syntax-case #'(((a 1) (b 2) (c 3))
+ ((d 4) (e 5) (f 6))) ()
+ ((((k v) ...) ...) (the-environment)))))
+ (equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env))
+ '((a b c 1 2 3) (d e f 4 5 6)))))
+
+ (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
- [PATCH] Implement local-eval, local-compile, and the-environment (v4),
Mark H Weaver <=