From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] local-eval, local-compile, and the-environment (v3) Date: Sun, 15 Jan 2012 01:27:54 -0500 Message-ID: <8762gd5vkl.fsf@netris.org> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1326608944 31242 80.91.229.12 (15 Jan 2012 06:29:04 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sun, 15 Jan 2012 06:29:04 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Jan 15 07:28:56 2012 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([140.186.70.17]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1RmJaJ-0007d8-NI for guile-devel@m.gmane.org; Sun, 15 Jan 2012 07:28:56 +0100 Original-Received: from localhost ([::1]:43147 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RmJaH-0004Qe-9C for guile-devel@m.gmane.org; Sun, 15 Jan 2012 01:28:53 -0500 Original-Received: from eggs.gnu.org ([140.186.70.92]:57998) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RmJaC-0004QY-UZ for guile-devel@gnu.org; Sun, 15 Jan 2012 01:28:51 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1RmJa9-0007lv-Sc for guile-devel@gnu.org; Sun, 15 Jan 2012 01:28:48 -0500 Original-Received: from world.peace.net ([96.39.62.75]:44611) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RmJa9-0007ZE-Ju for guile-devel@gnu.org; Sun, 15 Jan 2012 01:28:45 -0500 Original-Received: from c-98-216-245-176.hsd1.ma.comcast.net ([98.216.245.176] helo=yeeloong) by world.peace.net with esmtpsa (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.69) (envelope-from ) id 1RmJZp-0004HJ-E5; Sun, 15 Jan 2012 01:28:26 -0500 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) X-Received-From: 96.39.62.75 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:13511 Archived-At: --=-=-= Content-Type: text/plain Hello all, Here's the third version of my simple `local-eval' patch. Notable changes from last time: * Pattern variables are now captured properly. * `the-environment' now works as advertised within macro definitions. * Added doc strings for `local-eval' and `local-compile'. I am open to reimplementing this in a different way for 2.0.5, along the lines suggested by Andy. I'd like to capture all bindings, not just the ones reachable by symbols. I'd like to support _all_ lexical bindings, including local syntax transformers. I'm also warming to the idea of standardizing on variable objects as a way to represent mutable lexicals. However, there's no time to do this for 2.0.4. That job depends on other big jobs, notably a major overhaul of the evaluator. Nonetheless, I think it is very important to include this simple implementation in 2.0.4. This is a BUG FIX, the bug being that `local-eval' was removed from underneath Lilypond's feet. A partial implementation (that almost certainly does everything they need) is _far_ better than none at all. Lilypond can only depend on `local-eval' if installations of Guile without it are quite rare. If we can get this in 2.0.4, there's hope that we can make Guile 2.0.[0-3] rare. Please consider it. This implementation is quite robust. Thanks, Mark --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-Implement-local-eval-local-compile-and-the-environme-NO-PP.patch Content-Description: [PATCH] Implement local-eval, local-compile, and the-environment (v3) >From 215758081534a641df9bc9d8452f4fc35769e8cc Mon Sep 17 00:00:00 2001 From: Mark H Weaver 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 | 38 + libguile/debug.c | 13 +- libguile/debug.h | 4 +- module/Makefile.am | 5 +- module/ice-9/local-eval.scm | 151 + module/ice-9/psyntax-pp.scm |15387 +++++++++++++++++-------------- module/ice-9/psyntax.scm | 124 + test-suite/standalone/test-loose-ends.c | 16 +- test-suite/tests/eval.test | 87 +- 9 files changed, 8846 insertions(+), 6979 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 2e48dcb..72dd4df 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -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 @@ -954,6 +955,43 @@ 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)} has +some limitations. It 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. 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..7df94e1 --- /dev/null +++ b/module/ice-9/local-eval.scm @@ -0,0 +1,151 @@ +;;; -*- 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 module wrapper boxes pattern-bindings + var-names pattern-var-names unsupported-names) + lexical-environment? + (module lexenv-module) + (wrapper lexenv-wrapper) + (boxes lexenv-boxes) + (pattern-bindings lexenv-pattern-bindings) + (var-names lexenv-var-names) + (pattern-var-names lexenv-pattern-var-names) + (unsupported-names lexenv-unsupported-names)) + +(set-record-type-printer! + lexical-environment-type + (lambda (e port) + (format port "#" + (module-name (lexenv-module e)) + (reverse (map (lambda (name box) (list name (box))) + (lexenv-var-names e) (lexenv-boxes e))) + (reverse (lexenv-pattern-var-names e)) + (reverse (lexenv-unsupported-names e))))) + +(define (local-eval x e) + "Evaluate the expression @var{x} within the lexical environment @var{e}." + (cond ((lexical-environment? e) + (apply (eval ((lexenv-wrapper e) x) + (lexenv-module e)) + (append (lexenv-boxes e) + (lexenv-pattern-bindings 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 () #,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) + (apply (compile ((lexenv-wrapper e) x) + #:env (lexenv-module e) + #:from 'scheme #:opts opts) + (append (lexenv-boxes e) + (lexenv-pattern-bindings 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 () #,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 ...)))) + #'(make-lexical-environment + module + (lambda (expression) #`(box-lambda* + #,'(v ...) + #,'(pvar ...) + #,'(pvar-lvl ...) + #,'(unsupported ...) + #,expression)) + (list box ...) + (list #'nested-pvar ...) + '(v ...) + '(pvar ...) + '(unsupported ...))))))) + +(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 (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 1bf3c32..66e4583 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -786,6 +786,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. @@ -1803,6 +1852,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..6848c5e 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,86 @@ (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 () + (define-syntax-rule (test) + (let ((x 1) (y 2)) + (the-environment))) + (let ((env (let ((x 111) (y 222)) + (test)))) + (equal? (local-eval '(list x y) env) + '(1 2))))) + + (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 --=-=-=--