Hi Mark!
Thanks for your review of my patches. I would like to say, "our
patches", as they are not really mine, but I understand if you don't
want to claim parentage in this case :)
I fixed the module-related scope issues by adding a new accessor for
syntax objects, `syntax-module'. It is like Racket's
`syntax-source-module'. I added your expanded test to eval.test, and it
works fine.
You mention versioning, but I believe that this is a non-issue. If we
want to change the format of <lexical-environment>, we have two more
compelling options. One would be to make a compatible change, but
that's not always possible. The second would be to define another
<lexical-environment-2> or something; new expansions of
`the-environment' would embed references to this new vtable. Record
type predicates could distinguish them for the purposes of
local-eval/local-compile.
Here are the current patches. I've manually removed the parts that
patch psyntax-pp.scm, to not hurt our eyeballs :)
>From 68673f7507736f9a39d2d1eac9ef2a9ad1fd80dc Mon Sep 17 00:00:00 2001
From: Andy Wingo <wi...@pobox.com>
Date: Sun, 15 Jan 2012 18:39:44 +0100
Subject: [PATCH 1/3] add syntax-locally-bound-identifiers
* module/ice-9/boot-9.scm (syntax-locally-bound-identifiers): Declare
variable.
* module/ice-9/psyntax.scm: Add locally-bound-identifiers helper, and
define syntax-locally-bound-identifiers.
* module/ice-9/psyntax-pp.scm: Regenerated.
* doc/ref/api-macros.texi: Document the new procedure.
---
doc/ref/api-macros.texi | 37 +-
module/ice-9/boot-9.scm | 1 +
module/ice-9/psyntax-pp.scm |24438 +++++++++++++++++++++++--------------------
module/ice-9/psyntax.scm | 59 +-
4 files changed, 13078 insertions(+), 11457 deletions(-)
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 4702d2f..02b5d5c 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -744,7 +744,7 @@ information with macros:
(define-syntax-rule (with-aux aux value)
(let ((trans value))
(set! (aux-property trans) aux)
- trans)))
+ trans))
(define-syntax retrieve-aux
(lambda (x)
(syntax-case x ()
@@ -768,6 +768,41 @@ information with macros:
a syntax transformer; to call it otherwise will signal an error.
@end deffn
+@deffn {Scheme Procedure} syntax-locally-bound-identifiers id
+Return a list of identifiers that were visible lexically when the
+identifier @var{id} was created, in order from outermost to innermost.
+
+This procedure is intended to be used in specialized procedural macros,
+to provide a macro with the set of bound identifiers that the macro can
+reference.
+
+As a technical implementation detail, the identifiers returned by
+@code{syntax-locally-bound-identifiers} will be anti-marked, like the
+syntax object that is given as input to a macro. This is to signal to
+the macro expander that these bindings were present in the original
+source, and do not need to be hygienically renamed, as would be the case
+with other introduced identifiers. See the discussion of hygiene in
+section 12.1 of the R6RS, for more information on marks.
+
+@example
+(define (local-lexicals id)
+ (filter (lambda (x)
+ (eq? (syntax-local-binding x) 'lexical))
+ (syntax-locally-bound-identifiers id)))
+(define-syntax lexicals
+ (lambda (x)
+ (syntax-case x ()
+ ((lexicals) #'(lexicals lexicals))
+ ((lexicals scope)
+ (with-syntax (((id ...) (local-lexicals #'scope)))
+ #'(list (cons 'id id) ...))))))
+
+(let* ((x 10) (x 20)) (lexicals))
+@result{} ((x . 10) (x . 20))
+@end example
+@end deffn
+
+
@node Defmacros
@subsection Lisp-style Macro Definitions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 2c87d13..cd55203 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -390,6 +390,7 @@ If there is no handler at all, Guile prints an error and then exits."
(define bound-identifier=? #f)
(define free-identifier=? #f)
(define syntax-local-binding #f)
+(define syntax-locally-bound-identifiers #f)
;; $sc-dispatch is an implementation detail of psyntax. It is used by
;; expanded macros, to dispatch an input against a set of patterns.
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index fd33e98..024bb85 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)))))
+ ;; A helper procedure for syntax-locally-bound-identifiers, which
+ ;; itself is a helper for transformer procedures.
+ ;; `locally-bound-identifiers' returns a list of all bindings
+ ;; visible to a syntax object with the given wrap. They are in
+ ;; order from outer to inner.
+ ;;
+ ;; The purpose of this procedure is to give a transformer procedure
+ ;; references on bound identifiers, that the transformer can then
+ ;; introduce some of them in its output. As such, the identifiers
+ ;; are anti-marked, so that rebuild-macro-output doesn't apply new
+ ;; marks to them.
+ ;;
+ (define locally-bound-identifiers
+ (lambda (w mod)
+ (define scan
+ (lambda (subst results)
+ (if (null? subst)
+ results
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (scan (cdr subst) results)
+ (let ((symnames (ribcage-symnames fst))
+ (marks (ribcage-marks fst)))
+ (if (vector? symnames)
+ (scan-vector-rib subst symnames marks results)
+ (scan-list-rib subst symnames marks results))))))))
+ (define scan-list-rib
+ (lambda (subst symnames marks results)
+ (let f ((symnames symnames) (marks marks) (results results))
+ (if (null? symnames)
+ (scan (cdr subst) results)
+ (f (cdr symnames) (cdr marks)
+ (cons (wrap (car symnames)
+ (anti-mark (make-wrap (car marks) subst))
+ mod)
+ results))))))
+ (define scan-vector-rib
+ (lambda (subst symnames marks results)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0) (results results))
+ (if (fx= i n)
+ (scan (cdr subst) results)
+ (f (fx+ i 1)
+ (cons (wrap (vector-ref symnames i)
+ (anti-mark (make-wrap (vector-ref marks i) subst))
+ mod)
+ results)))))))
+ (scan (wrap-subst w) '())))
+
;; Returns three values: binding type, binding value, the module (for
;; resolving toplevel vars).
(define (resolve-identifier id w r mod)
@@ -2478,7 +2527,7 @@
(set! syntax-local-binding
(lambda (id)
- (arg-check nonsymbol-id? id 'syntax-local-value)
+ (arg-check nonsymbol-id? id 'syntax-local-binding)
(with-transformer-environment
(lambda (e r w s rib mod)
(define (strip-anti-mark w)
@@ -2500,9 +2549,15 @@
((macro) (values 'macro value))
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
- ((global) (values 'global (cons value mod)))
+ ((global) (values 'global (cons value (cdr mod))))
(else (values 'other #f)))))))))
+ (set! syntax-locally-bound-identifiers
+ (lambda (x)
+ (arg-check nonsymbol-id? x 'syntax-locally-bound-identifiers)
+ (locally-bound-identifiers (syntax-object-wrap x)
+ (syntax-object-module x))))
+
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
--
1.7.8.3
>From 4a8740595df89ae29fe3eef0f133e78787665b9a Mon Sep 17 00:00:00 2001
From: Andy Wingo <wi...@pobox.com>
Date: Mon, 23 Jan 2012 12:31:33 +0100
Subject: [PATCH 2/3] add syntax-module
* module/ice-9/psyntax.scm (syntax-module): New accessor for syntax
objects.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/boot-9.scm: Declare syntax-module.
* doc/ref/api-macros.texi: Document it.
---
doc/ref/api-macros.texi | 5 +
module/ice-9/boot-9.scm | 1 +
module/ice-9/psyntax-pp.scm |14124 ++++++++++++++++++++++---------------------
module/ice-9/psyntax.scm | 5 +
4 files changed, 7082 insertions(+), 7053 deletions(-)
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 02b5d5c..2b6f15a 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -706,6 +706,11 @@ Return the source properties that correspond to the syntax object
@var{x}. @xref{Source Properties}, for more information.
@end deffn
+@deffn {Scheme Procedure} syntax-module id
+Return the name of the module whose source contains the identifier
+@var{id}.
+@end deffn
+
@deffn {Scheme Procedure} syntax-local-binding id
Resolve the identifer @var{id}, a syntax object, within the current
lexical environment, and return two values, the binding type and a
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index cd55203..3914ff3 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -385,6 +385,7 @@ If there is no handler at all, Guile prints an error and then exits."
(define datum->syntax #f)
(define syntax->datum #f)
(define syntax-source #f)
+(define syntax-module #f)
(define identifier? #f)
(define generate-temporaries #f)
(define bound-identifier=? #f)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 024bb85..00cb549 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2525,6 +2525,11 @@
(set! syntax-source
(lambda (x) (source-annotation x)))
+ (set! syntax-module
+ (lambda (id)
+ (arg-check nonsymbol-id? id 'syntax-module)
+ (cdr (syntax-object-module id))))
+
(set! syntax-local-binding
(lambda (id)
(arg-check nonsymbol-id? id 'syntax-local-binding)
--
1.7.8.3
>From 93358db7885046ad878c9abdd05428811c4ef384 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wi...@pobox.com>
Date: Tue, 3 Jan 2012 04:02:08 -0500
Subject: [PATCH 3/3] Implement `local-eval', `local-compile', and
`the-environment'
* module/ice-9/local-eval.scm: New module (ice-9 local-eval) which
exports `the-environment', `local-eval', and `local-compile'.
* 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.
Based on a patch by Mark H Weaver <m...@netris.org>.
---
doc/ref/api-evaluation.texi | 34 ++++
libguile/debug.c | 13 ++-
libguile/debug.h | 4 +-
module/Makefile.am | 5 +-
module/ice-9/local-eval.scm | 250 +++++++++++++++++++++++++++++++
test-suite/standalone/test-loose-ends.c | 16 ++-
test-suite/tests/eval.test | 95 ++++++++++++-
7 files changed, 410 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 ef3e602..cc62270 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
@@ -980,6 +981,39 @@ value.
@end deffn
+@node Local Evaluation
+@subsection Local Evaluation
+
+@deffn syntax the-environment
+Captures and returns a lexical environment for use with
+@code{local-eval} or @code{local-compile}.
+@end deffn
+
+@deffn {Scheme Procedure} local-eval exp env
+@deffnx {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
+@code{(the-environment)}, with the resulting procedure called by
+@code{local-eval}. 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}.
+@end deffn
+
+@deffn {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
+@code{local-eval}. @var{opts} specifies the compilation options.
+@end deffn
+
+Note that the current implementation of @code{(the-environment)} does
+not capture local syntax transformers bound by @code{let-syntax},
+@code{letrec-syntax} or non-top-level @code{define-syntax} forms. Any
+attempt to reference such captured syntactic keywords via
+@code{local-eval} or @code{local-compile} produces an error.
+
+
@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..e771d1c
--- /dev/null
+++ b/module/ice-9/local-eval.scm
@@ -0,0 +1,250 @@
+;;; -*- 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 (the-environment local-eval local-compile))
+
+(define-record-type lexical-environment-type
+ (make-lexical-environment scope wrapper boxes patterns)
+ lexical-environment?
+ (scope lexenv-scope)
+ (wrapper lexenv-wrapper)
+ (boxes lexenv-boxes)
+ (patterns lexenv-patterns))
+
+(set-record-type-printer!
+ lexical-environment-type
+ (lambda (e port)
+ (format port "#<lexical-environment ~S (~S bindings)>"
+ (syntax-module (lexenv-scope e))
+ (+ (length (lexenv-boxes e)) (length (lexenv-patterns e))))))
+
+(define-syntax syntax-object-of
+ (lambda (form)
+ (syntax-case form ()
+ ((_ x) #`(quote #,(datum->syntax #'x #'x))))))
+
+(define-syntax-rule (make-box v)
+ (case-lambda
+ (() v)
+ ((x) (set! v x))))
+
+(define (make-transformer-from-box id trans)
+ (set-procedure-property! trans 'identifier-syntax-box id)
+ trans)
+
+(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 (unsupported-binding name)
+ (make-variable-transformer
+ (lambda (x)
+ (syntax-violation
+ 'local-eval
+ "unsupported binding captured by (the-environment)"
+ x))))
+
+(define (within-nested-ellipses id lvl)
+ (let loop ((s id) (n lvl))
+ (if (zero? n)
+ s
+ (loop #`(#,s (... ...)) (- n 1)))))
+
+;; Analyze the set of bound identifiers IDS. Return four values:
+;;
+;; capture: A list of forms that will be emitted in the expansion of
+;; `the-environment' to capture lexical variables.
+;;
+;; formals: Corresponding formal parameters for use in the lambda that
+;; re-introduces those variables. These are temporary identifiers, and
+;; as such if we have a nested `the-environment', there is no need to
+;; capture them. (See the notes on nested `the-environment' and
+;; proxies, below.)
+;;
+;; wrappers: A list of procedures of type SYNTAX -> SYNTAX, used to wrap
+;; the expression to be evaluated in forms that re-introduce the
+;; variable. The forms will be nested so that the variable shadowing
+;; semantics of the original form are maintained.
+;;
+;; patterns: A terrible hack. The issue is that for pattern variables,
+;; we can't emit lexically nested with-syntax forms, like:
+;;
+;; (with-syntax ((foo 1)) (the-environment))
+;; => (with-syntax ((foo 1))
+;; ... #'(with-syntax ((foo ...)) ... exp) ...)
+;;
+;; The reason is that the outer "foo" substitutes into the inner "foo",
+;; yielding something like:
+;;
+;; (with-syntax ((foo 1))
+;; ... (with-syntax ((1 ...)) ...)
+;;
+;; Which ain't what we want. So we hide the information needed to
+;; re-make the inner pattern binding form in the lexical environment
+;; object, and then introduce those identifiers via another with-syntax.
+;;
+;;
+;; There are four different kinds of lexical bindings: normal lexicals,
+;; macros, displaced lexicals, and pattern variables. See the
+;; documentation of syntax-local-binding for more info on these.
+;;
+;; We capture normal lexicals via `make-box', which creates a
+;; case-lambda that can reference or set a variable. These get
+;; re-introduced with an identifier-syntax.
+;;
+;; We can't capture macros currently. However we do recognize our own
+;; macros that are actually proxying lexicals, so that nested
+;; `the-environment' forms are possible. In that case we drill down to
+;; the identifier for the already-existing box, and just capture that
+;; box.
+;;
+;; And that's it: we skip displaced lexicals, and the pattern variables
+;; are discussed above.
+;;
+(define (analyze-identifiers ids)
+ (define (mktmp)
+ (datum->syntax #'here (gensym "t ")))
+ (let lp ((ids ids) (capture '()) (formals '()) (wrappers '()) (patterns '()))
+ (cond
+ ((null? ids)
+ (values capture formals wrappers patterns))
+ (else
+ (let ((id (car ids)) (ids (cdr ids)))
+ (call-with-values (lambda () (syntax-local-binding id))
+ (lambda (type val)
+ (case type
+ ((lexical)
+ (if (or-map (lambda (x) (bound-identifier=? x id)) formals)
+ (lp ids capture formals wrappers patterns)
+ (let ((t (mktmp)))
+ (lp ids
+ (cons #`(make-box #,id) capture)
+ (cons t formals)
+ (cons (lambda (x)
+ #`(let-syntax ((#,id (identifier-syntax-from-box #,t)))
+ #,x))
+ wrappers)
+ patterns))))
+ ((displaced-lexical)
+ (lp ids capture formals wrappers patterns))
+ ((macro)
+ (let ((b (procedure-property val 'identifier-syntax-box)))
+ (if b
+ (lp ids (cons b capture) (cons b formals)
+ (cons (lambda (x)
+ #`(let-syntax ((#,id (identifier-syntax-from-box #,b)))
+ #,x))
+ wrappers)
+ patterns)
+ (lp ids capture formals
+ (cons (lambda (x)
+ #`(let-syntax ((#,id (unsupported-binding '#,id)))
+ #,x))
+ wrappers)
+ patterns))))
+ ((pattern-variable)
+ (let ((t (datum->syntax id (gensym "p ")))
+ (nested (within-nested-ellipses id (cdr val))))
+ (lp ids capture formals
+ (cons (lambda (x)
+ #`(with-syntax ((#,t '#,nested))
+ #,x))
+ wrappers)
+ ;; This dance is to hide these pattern variables
+ ;; from the expander.
+ (cons (list (datum->syntax #'here (syntax->datum id))
+ (cdr val)
+ t)
+ patterns))))
+ (else
+ (error "what" type val))))))))))
+
+(define-syntax the-environment
+ (lambda (x)
+ (syntax-case x ()
+ ((the-environment)
+ #'(the-environment the-environment))
+ ((the-environment scope)
+ (call-with-values (lambda ()
+ (analyze-identifiers
+ (syntax-locally-bound-identifiers #'scope)))
+ (lambda (capture formals wrappers patterns)
+ (define (wrap-expression x)
+ (let lp ((x x) (wrappers wrappers))
+ (if (null? wrappers)
+ x
+ (lp ((car wrappers) x) (cdr wrappers)))))
+ (with-syntax (((f ...) formals)
+ ((c ...) capture)
+ (((pname plvl pformal) ...) patterns)
+ (wrapped (wrap-expression #'(begin #f exp))))
+ #'(make-lexical-environment
+ #'scope
+ (lambda (exp pformal ...)
+ (with-syntax ((exp exp)
+ (pformal pformal)
+ ...)
+ #'(lambda (f ...)
+ wrapped)))
+ (list c ...)
+ (list (list 'pname plvl #'pformal) ...)))))))))
+
+(define (env-module e)
+ (cond
+ ((lexical-environment? e) (resolve-module (syntax-module (lexenv-scope e))))
+ ((module? e) e)
+ (else (error "invalid lexical environment" e))))
+
+(define (env-boxes e)
+ (cond
+ ((lexical-environment? e) (lexenv-boxes e))
+ ((module? e) '())
+ (else (error "invalid lexical environment" e))))
+
+(define (local-wrap x e)
+ (cond
+ ((lexical-environment? e)
+ (apply (lexenv-wrapper e)
+ (datum->syntax (lexenv-scope e) x)
+ (map (lambda (l)
+ (let ((name (car l))
+ (lvl (cadr l))
+ (scope (caddr l)))
+ (within-nested-ellipses (datum->syntax scope name) lvl)))
+ (lexenv-patterns e))))
+ ((module? e) `(lambda () #f ,exp))
+ (else (error "invalid lexical environment" e))))
+
+(define (local-eval x e)
+ "Evaluate the expression @var{x} within the lexical environment @var{e}."
+ (apply (eval (local-wrap x e) (env-module e))
+ (env-boxes e)))
+
+(define* (local-compile x e #:key (opts '()))
+ "Compile and evaluate the expression @var{x} within the lexical
+environment @var{e}."
+ (apply (compile (local-wrap x e) #:env (env-module e)
+ #:from 'scheme #:opts opts)
+ (env-boxes e)))
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..f532059 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,94 @@
(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.8.3
Andy
--
http://wingolog.org/
