From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andy Wingo Newsgroups: gmane.lisp.guile.devel Subject: local-eval on syntax-local-binding, bound-identifiers Date: Sun, 15 Jan 2012 23:17:37 +0100 Message-ID: <87sjjg7gqm.fsf@pobox.com> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1326665879 9766 80.91.229.12 (15 Jan 2012 22:17:59 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sun, 15 Jan 2012 22:17:59 +0000 (UTC) Cc: guile-devel To: "Mark H. Weaver" Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Jan 15 23:17:54 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 1RmYOe-0001Oa-J6 for guile-devel@m.gmane.org; Sun, 15 Jan 2012 23:17:52 +0100 Original-Received: from localhost ([::1]:56258 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RmYOe-0008Ra-0O for guile-devel@m.gmane.org; Sun, 15 Jan 2012 17:17:52 -0500 Original-Received: from eggs.gnu.org ([140.186.70.92]:57161) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RmYOZ-0008RR-0o for guile-devel@gnu.org; Sun, 15 Jan 2012 17:17:49 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1RmYOV-0007dl-JF for guile-devel@gnu.org; Sun, 15 Jan 2012 17:17:46 -0500 Original-Received: from a-pb-sasl-sd.pobox.com ([74.115.168.62]:40313 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1RmYOV-0007dh-9o for guile-devel@gnu.org; Sun, 15 Jan 2012 17:17:43 -0500 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-sd.pobox.com (Postfix) with ESMTP id AE8448C7D; Sun, 15 Jan 2012 17:17:42 -0500 (EST) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to:cc :subject:date:message-id:mime-version:content-type; s=sasl; bh=m 83FvRhhfEPJXwp3ZxchUFO37pE=; b=ocfjbhOc1UKXvZwFnsWxXvQbcT6ch/Fvf TSD++ltQGIQl32E7jZ9KBrq2Qx1dShI/WbAgG+i7Vja+P+h/Iun/uBTAGs1qIVcH mMjV9KV+g7KBnvalkbFc8uEkfjvv2fG7RSbBg3y6wjdc2U2u+4Io0O+9numaUujI hbI7eaP6Ug= DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:cc :subject:date:message-id:mime-version:content-type; q=dns; s= sasl; b=gyR+Pvo+f3rMW2v/ktcDya4JrFG9zsSfXJ70ohgE+1lOJK2mj6jwpciU 2fypxccHvUGHoqItFG6nHm9SvrXex1wTdfFHl3zHNPVO0qDGmfz+R0dDG77NyLjy 7ENnUvE5elLc1emOPOko7tzbBlzWtcBZmyE7LCNLv2S9q+7ozuM= Original-Received: from a-pb-sasl-sd.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-sd.pobox.com (Postfix) with ESMTP id A62628C7C; Sun, 15 Jan 2012 17:17:42 -0500 (EST) Original-Received: from badger (unknown [90.164.198.39]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by a-pb-sasl-sd.pobox.com (Postfix) with ESMTPSA id 32ABF8C7B; Sun, 15 Jan 2012 17:17:41 -0500 (EST) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.3 (gnu/linux) X-Pobox-Relay-ID: BD85C43C-3FC6-11E1-8532-65B1DE995924-02397024!a-pb-sasl-sd.pobox.com X-detected-operating-system: by eggs.gnu.org: Solaris 10 (beta) X-Received-From: 74.115.168.62 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:13531 Archived-At: --=-=-= Hi Mark, I had made some noise about preferring an implementation of local-eval based on primitives from psyntax. But, I didn't clarify my argument by providing the primitives. Here are some patches that provide syntax-local-binding, as I noted in my previous mail, and also a procedure to get all identifiers that are visible within the scope of another identifier. I then refactored your patch to implement local-eval entirely in terms of these primitives and other normal macrology. What do you think? In the interests of time and debugging, I removed the support for pattern variables; it should be easy to add back. These are preliminary patches, but if this approach proves to be viable, I would prefer it to one that bakes the-environment into psyntax. WDYT? Regards, Andy --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-add-syntax-local-binding.patch >From 48d8e52e316984f2bf9380df85079bb5fa142253 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 15 Jan 2012 17:51:02 +0100 Subject: [PATCH 1/3] add syntax-local-binding * module/ice-9/boot-9.scm (syntax-local-binding): New binding. * module/ice-9/psyntax.scm: Locally define a fluid that holds the "transformer environment". with-transformer-environment calls a procedure with the transformer environment, or raises an error if called outside the extent of a transformer. Bind transformer-environment in expand-macro. (syntax-local-binding): New procedure to return binding information of a lexically bound identifier (a lexical, local macro, a pattern variable, or a displaced lexical). --- module/ice-9/boot-9.scm | 1 + module/ice-9/psyntax.scm | 39 +++++++++++++++++++++++++++++++++++++-- 2 files changed, 38 insertions(+), 2 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index f661d08..9cdd8d1 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -389,6 +389,7 @@ If there is no handler at all, Guile prints an error and then exits." (define generate-temporaries #f) (define bound-identifier=? #f) (define free-identifier=? #f) +(define syntax-local-binding #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 1bf3c32..30685bc 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -786,6 +786,14 @@ id)))))) (else (syntax-violation 'id-var-name "invalid id" id))))) + (define transformer-environment + (make-fluid + (lambda (k) + (error "called outside the dynamic extent of a syntax transformer")))) + + (define (with-transformer-environment k) + ((fluid-ref transformer-environment) k)) + ;; 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. @@ -1321,8 +1329,10 @@ (syntax-violation #f "encountered raw symbol in macro output" (source-wrap e w (wrap-subst w) mod) x)) (else (decorate-source x s))))) - (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) - (new-mark)))) + (with-fluids ((transformer-environment + (lambda (k) (k e r w s rib mod)))) + (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) + (new-mark))))) (define expand-body ;; In processing the forms of the body, we create a new, empty wrap. @@ -2435,6 +2445,31 @@ (set! syntax-source (lambda (x) (source-annotation x))) + (set! syntax-local-binding + (lambda (id) + (arg-check nonsymbol-id? id 'syntax-local-value) + (with-transformer-environment + (lambda (e r w s rib mod) + (define (strip-anti-mark w) + (let ((ms (wrap-marks w)) (s (wrap-subst w))) + (if (and (pair? ms) (eq? (car ms) the-anti-mark)) + ;; output is from original text + (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) + ;; output introduced by macro + (make-wrap ms (if rib (cons rib s) s))))) + (let ((label (id-var-name (syntax-object-expression id) + (strip-anti-mark (syntax-object-wrap id))))) + (if (not (string? label)) + (error "identifier not lexically bound" id)) + (let ((b (assq-ref r label))) + (if b + (case (binding-type b) + ((lexical) (values 'lexical (binding-value b))) + ((macro) (values 'local-macro (binding-value b))) + ((syntax) (values 'pattern-variable (binding-value b))) + (else (error "unpossible!" b))) + (values 'displaced-lexical #f)))))))) + (set! generate-temporaries (lambda (ls) (arg-check list? ls 'generate-temporaries) -- 1.7.8.3 --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0002-add-bound-identifiers.patch >From 2c3da44320019453115811af386febaa7eb241c3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 15 Jan 2012 18:39:44 +0100 Subject: [PATCH 2/3] add bound-identifiers * module/ice-9/boot-9.scm (bound-identifiers): Declare variable. * module/ice-9/psyntax.scm: Add all-bound-identifiers helper, and define bound-identifiers. The identifiers are anti-marked so that syntax transformers can introduce them, as-is. --- module/ice-9/boot-9.scm | 1 + module/ice-9/psyntax.scm | 49 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 0 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 9cdd8d1..b8aa842 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -389,6 +389,7 @@ If there is no handler at all, Guile prints an error and then exits." (define generate-temporaries #f) (define bound-identifier=? #f) (define free-identifier=? #f) +(define bound-identifiers #f) (define syntax-local-binding #f) ;; $sc-dispatch is an implementation detail of psyntax. It is used by diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 30685bc..25543e0 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -786,6 +786,48 @@ id)))))) (else (syntax-violation 'id-var-name "invalid id" id))))) + ;; + ;; all-bound-identifiers returns a list of all lexically bound + ;; identifiers, as syntax objects. They are in order from outer to + ;; inner. + ;; + (define all-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) '()))) + (define transformer-environment (make-fluid (lambda (k) @@ -2470,6 +2512,13 @@ (else (error "unpossible!" b))) (values 'displaced-lexical #f)))))))) + (set! bound-identifiers + (lambda (x) + (arg-check nonsymbol-id? x 'bound-identifiers) + (reverse + (all-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 --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0003-Implement-local-eval-local-compile-and-the-environme.patch >From ddea51310227155e3771c3e6acbbecf24dc74c42 Mon Sep 17 00:00:00 2001 From: Mark H Weaver 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. --- doc/ref/api-evaluation.texi | 38 ++++++++ libguile/debug.c | 13 +++- libguile/debug.h | 4 +- module/Makefile.am | 5 +- module/ice-9/local-eval.scm | 150 +++++++++++++++++++++++++++++++ test-suite/standalone/test-loose-ends.c | 16 +++- test-suite/tests/eval.test | 79 ++++++++++++++++- 7 files changed, 298 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 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..cb74881 --- /dev/null +++ b/module/ice-9/local-eval.scm @@ -0,0 +1,150 @@ +;;; -*- 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 module wrapper boxes) + lexical-environment? + (module lexenv-module) + (wrapper lexenv-wrapper) + (boxes lexenv-boxes)) + +(set-record-type-printer! + lexical-environment-type + (lambda (e port) + (format port "#" + (module-name (lexenv-module e)) (length (lexenv-boxes e))))) + +(define-syntax-rule (make-box v) + (case-lambda + (() v) + ((x) (set! v x)))) + +(define-syntax let*-syntax + (syntax-rules () + ((_ () e e* ...) + (begin e e* ...)) + ((_ ((id trans) (id* trans*) ...) e e* ...) + (let-syntax ((id trans)) + (let*-syntax ((id* trans*) ...) + e e* ...))))) + +(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 (unsupported-binding name) + (make-variable-transformer + (lambda (x) + (syntax-violation + 'local-eval + "unsupported binding captured by (the-environment)" + x)))) + +(define (partition-identifiers ids) + (let lp ((ids ids) (lexical '()) (other '())) + (if (null? ids) + (values lexical other) + (call-with-values (lambda () (syntax-local-binding (car ids))) + (lambda (type val) + (cond + ((eq? type 'lexical) + (lp (cdr ids) + (acons (car ids) (datum->syntax #'here (gensym)) + lexical) + other)) + ((and (eq? type 'local-macro) + (procedure-property val 'identifier-syntax-box)) + => (lambda (id) + (lp (cdr ids) + (acons (car ids) id lexical) + other))) + (else + (lp (cdr ids) lexical (cons (car ids) other))))))))) + +(define-syntax the-environment + (lambda (x) + (syntax-case x () + ((the-environment) + #'(the-environment the-environment)) + ((the-environment scope) + (call-with-values (lambda () + (partition-identifiers (bound-identifiers #'scope))) + (lambda (lexical other) + (with-syntax ((module (datum->syntax #'here (module-name (current-module)))) + (((v . t) ...) lexical) + ((u ...) other)) + #'(make-lexical-environment + (resolve-module 'module) + (lambda (exp) + (with-syntax ((exp (datum->syntax #'scope exp))) + #'(lambda (t ...) + (let*-syntax ((v (identifier-syntax-from-box t)) + ... + (u (unsupported-binding 'u)) + ...) + #f ; force expression context + exp)))) + (list (make-box v) ...))))))))) + +(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)) + (lexenv-boxes 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) + (lexenv-boxes 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)))) 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..73f9140 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,78 @@ (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 "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 --=-=-= -- http://wingolog.org/ --=-=-=--