From 93358db7885046ad878c9abdd05428811c4ef384 Mon Sep 17 00:00:00 2001 From: Andy Wingo 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 . --- 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 "#" + (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