Hello all, If Andy finishes his version of `local-eval', that's all well and good, and I'm happy to use his version. However, in case he doesn't have time to address the remaining issues in his implementation before 2.0.4, or if he'd like some more time to think about the other new interfaces before committing them to our API...
I've attached below my latest version of `local-eval', which has the following advantages: * Commits us to _no_ new APIs other than `local-eval', `local-compile', and `the-environment'. * Does _not_ require universally-unique gensyms, so we could revert that patch if desired. * Uses the simple future-proof `evaluator procedure' representation for lexical environments, allowing even radical changes to the implementation of `the-environment' while retaining ABI compatibility. Call me stubborn, but I _still_ think it would be better to use this implementation in 2.0.4, and to revert both `syntax-local-binding' and maybe also `universally-unique gensyms' for now. I'm not opposed to Andy's approach, but I think we need more time to debate the relevant interfaces. This way, we have complete freedom to do whatever we want in 2.0.5 and beyond, without making any hasty commitments. Best, Mark
>From 496c5ae9f8d8b835dcb9a032447df2f46e2d63bd Mon Sep 17 00:00:00 2001 From: Mark H Weaver <m...@netris.org> Date: Tue, 3 Jan 2012 04:02:08 -0500 Subject: [PATCH] Implement `local-eval', `local-compile', and `the-environment' * module/ice-9/local-eval.scm: New module (ice-9 local-eval) which exports `local-eval' and `local-compile'. This module also contains (non-exported) syntax transformers used internally by psyntax to implement `the-environment'. * module/ice-9/psyntax.scm: New core syntax form `the-environment'. New internal procedure `reachable-bindings' generates the list of lexical bindings reachable using normal symbols (as opposed to syntax objects which could reach a larger set of bindings). * libguile/debug.c (scm_local_eval): New C function that calls the Scheme implementation of `local-eval' in (ice-9 local-eval). * libguile/debug.h (scm_local_eval): Add prototype. * doc/ref/api-evaluation.texi (Local Evaluation): Add documentation. * test-suite/tests/eval.test (local evaluation): Add tests. * test-suite/standalone/test-loose-ends.c (test_scm_local_eval): Add test. * module/Makefile.am: Add ice-9/local-eval.scm. --- doc/ref/api-evaluation.texi | 38 ++++++++ libguile/debug.c | 13 +++- libguile/debug.h | 4 +- module/Makefile.am | 5 +- module/ice-9/local-eval.scm | 155 +++++++++++++++++++++++++++++++ module/ice-9/psyntax.scm | 124 ++++++++++++++++++++++++ test-suite/standalone/test-loose-ends.c | 16 +++- test-suite/tests/eval.test | 92 ++++++++++++++++++- 8 files changed, 440 insertions(+), 7 deletions(-) create mode 100644 module/ice-9/local-eval.scm diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index ed3b88c..37cdc2e 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -20,6 +20,7 @@ loading, evaluating, and compiling Scheme code at run time. * Load Paths:: Where Guile looks for code. * Character Encoding of Source Files:: Loading non-ASCII Scheme code from file. * Delayed Evaluation:: Postponing evaluation until it is needed. +* Local Evaluation:: Evaluation in a local lexical environment. @end menu @@ -987,6 +988,43 @@ value. @end deffn +@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..0a0b867 --- /dev/null +++ b/module/ice-9/local-eval.scm @@ -0,0 +1,155 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; +;;; Copyright (C) 2012 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this library; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (ice-9 local-eval) + #:use-module (ice-9 format) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (system base compile) + #:export (local-eval local-compile)) + +(define-record-type lexical-environment-type + (make-lexical-environment version module evaluator) + lexical-environment? + (version lexenv-version) + (module lexenv-module) + (evaluator lexenv-evaluator)) + +(define (lexenv-major-version e) (car (lexenv-version e))) +(define (lexenv-minor-version e) (cdr (lexenv-version e))) + +(set-record-type-printer! + lexical-environment-type + (lambda (e port) + (format port "#<lexical-environment ~S ~S>" + (module-name (lexenv-module e)) + (lexenv-version e)))) + +(define (local-eval x e) + "Evaluate the expression @var{x} within the lexical environment @var{e}." + (cond ((lexical-environment? e) + (case (lexenv-major-version e) + ((1) ((lexenv-evaluator e) x #f)) + (else (error "local-eval: unsupported lexenv version" e)))) + ((module? e) + ;; Here we evaluate the expression within `lambda', and then + ;; call the resulting procedure outside of the dynamic extent + ;; of `eval'. We do this because `eval' sets (current-module) + ;; within its dynamic extent, and we don't want that. Also, + ;; doing it this way makes this a proper tail call. + ((eval #`(lambda () #f #,x) e))) + (else (error "local-eval: invalid lexical environment" e)))) + +(define* (local-compile x e #:key (opts '())) + "Compile and evaluate the expression @var{x} within the lexical environment @var{e}." + (cond ((lexical-environment? e) + (case (lexenv-major-version e) + ((1) ((lexenv-evaluator e) x opts)) + (else (error "local-compile: unsupported lexenv version" e)))) + ((module? e) + ;; Here we compile the expression within `lambda', and then + ;; call the resulting procedure outside of the dynamic extent + ;; of `compile'. We do this because `compile' sets + ;; (current-module) during evaluation, and we don't want that. + ((compile #`(lambda () #f #,x) + #:env e #:from 'scheme #:opts opts))) + (else (error "local-compile: invalid lexical environment" e)))) + +(define-syntax-rule (make-box v) + (case-lambda + (() v) + ((x) (set! v x)))) + +(define-syntax box-lambda* + (lambda (x) + (syntax-case x () + ((_ (v ...) (pvar ...) (pvar-lvl ...) (unsupported ...) e) + (with-syntax + (((nested-pvar ...) + (map within-nested-ellipses #'(pvar ...) #'(pvar-lvl ...)))) + #'(lambda (v ... pvar ...) + (let-syntax + ((v (identifier-syntax-from-box v)) + ... + (unsupported (unsupported-binding 'unsupported)) + ...) + (with-syntax + ((nested-pvar pvar) ...) + #f ; force expression context + e)))))))) + +(define-syntax capture-environment + (lambda (x) + (syntax-case x () + ((_ module (box ...) (v ...) (pvar ...) (pvar-lvl ...) (unsupported ...)) + (with-syntax + (((nested-pvar ...) + (map within-nested-ellipses #'(pvar ...) #'(pvar-lvl ...)))) + #'(let ((mod module) + (args (list box ... #'nested-pvar ...))) + (make-lexical-environment + '(1 . 0) ; (major . minor) version number + mod + (lambda (expression opts) + (let* ((wrapped-expr (list + ;; #'box-lambda* but without the + ;; extraneous wrap-subst ribcage + (vector 'syntax-object + 'box-lambda* + '((top)) + '(hygiene ice-9 local-eval)) + '(v ...) + '(pvar ...) + '(pvar-lvl ...) + '(unsupported ...) + expression)) + (proc (compile-or-eval wrapped-expr mod opts))) + (apply proc args)))))))))) + +(define-syntax-rule (identifier-syntax-from-box box) + (make-transformer-from-box + (syntax-object-of box) + (identifier-syntax (id (box)) + ((set! id x) (box x))))) + +(define-syntax syntax-object-of + (lambda (form) + (syntax-case form () + ((_ x) #`(quote #,(datum->syntax #'x #'x)))))) + +(define (make-transformer-from-box id trans) + (set-procedure-property! trans 'identifier-syntax-box id) + trans) + +(define (within-nested-ellipses s lvl) + (let loop ((s s) (n (syntax->datum lvl))) + (if (zero? n) s (loop #`(#,s (... ...)) + (- n 1))))) + +(define (compile-or-eval x mod opts) + (if opts + (compile x #:env mod #:from 'scheme #:opts opts) + (eval x mod))) + +(define (unsupported-binding name) + (make-variable-transformer + (lambda (x) + (syntax-violation + name + "unsupported binding captured by (the-environment)" + x)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index fd33e98..1eb3dd3 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -791,6 +791,55 @@ id)))))) (else (syntax-violation 'id-var-name "invalid id" id))))) + ;; + ;; reachable-bindings returns an alist containing one entry + ;; (sym . label) for each binding that is accessible using normal + ;; symbols. + ;; + ;; This implementation was derived from that of id-var-name (above), + ;; and closely mirrors its structure. + ;; + (define reachable-bindings + (lambda (w) + (define scan + (lambda (subst marks results) + (if (null? subst) + results + (let ((fst (car subst))) + (if (eq? fst 'shift) + (scan (cdr subst) (cdr marks) results) + (let ((symnames (ribcage-symnames fst))) + (if (vector? symnames) + (scan-vector-rib subst marks symnames fst results) + (scan-list-rib subst marks symnames fst results)))))))) + (define scan-list-rib + (lambda (subst marks symnames ribcage results) + (let f ((symnames symnames) (i 0) (results results)) + (cond + ((null? symnames) (scan (cdr subst) marks results)) + ((and (not (assq (car symnames) results)) + (same-marks? marks (list-ref (ribcage-marks ribcage) i))) + (f (cdr symnames) + (fx+ i 1) + (cons (cons (car symnames) + (list-ref (ribcage-labels ribcage) i)) + results))) + (else (f (cdr symnames) (fx+ i 1) results)))))) + (define scan-vector-rib + (lambda (subst marks symnames ribcage results) + (let ((n (vector-length symnames))) + (let f ((i 0) (results results)) + (cond + ((fx= i n) (scan (cdr subst) marks results)) + ((and (not (assq (vector-ref symnames i) results)) + (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) + (f (fx+ i 1) + (cons (cons (vector-ref symnames i) + (vector-ref (ribcage-labels ribcage) i)) + results))) + (else (f (fx+ i 1) results))))))) + (scan (wrap-subst w) (wrap-marks w) '()))) + ;; Returns three values: binding type, binding value, the module (for ;; resolving toplevel vars). (define (resolve-identifier id w r mod) @@ -1844,6 +1893,81 @@ (_ (syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) + (global-extend 'core 'the-environment + (lambda (e r w s mod) + (define ice-9/local-eval + (lambda (sym) + (wrap sym top-wrap '(private ice-9 local-eval)))) + (call-with-values + (lambda () + (syntax-case e () + ((x) (let ((id (wrap #'x w mod))) + (values (syntax-object-wrap id) + (syntax-object-module id)))) + (_ (syntax-violation 'the-environment "bad syntax" + (source-wrap e w s mod))))) + (lambda (w mod) + (with-syntax + ((make-box (ice-9/local-eval 'make-box)) + (module-name (cdr mod))) + (let* ((sym+labels (reachable-bindings w)) + (ids (map (lambda (sym+label) + (wrap (car sym+label) w mod)) + sym+labels)) + (bindings (map (lambda (sym+label) + (lookup (cdr sym+label) r mod)) + sym+labels)) + (categories (map (lambda (id b) + (case (binding-type b) + ((lexical) 'lexical) + ((syntax) 'pattern-var) + ((macro) (if (procedure-property + (binding-value b) + 'identifier-syntax-box) + 'already-boxed + ;; TODO: support macros + #f)) + (else #f))) + ids bindings)) + (maybe-boxes (map (lambda (id b c) + (case c + ((lexical) #`(make-box #,id)) + ((already-boxed) (procedure-property + (binding-value b) + 'identifier-syntax-box)) + (else #f))) + ids bindings categories)) + (maybe-pattern-bindings (map (lambda (b c) + (case c + ((pattern-var) (binding-value b)) + (else #f))) + bindings categories))) + (with-syntax + ((capture-environment (ice-9/local-eval 'capture-environment)) + (module #'(resolve-module 'module-name)) + (boxes (filter identity maybe-boxes)) + (var-ids (filter identity (map (lambda (maybe-box id) + (and maybe-box id)) + maybe-boxes ids))) + (pattern-var-ids (filter identity + (map (lambda (maybe-pattern-binding id) + (and maybe-pattern-binding id)) + maybe-pattern-bindings ids))) + (pattern-var-lvls (filter identity + (map (lambda (maybe-pattern-binding) + (and maybe-pattern-binding + (cdr maybe-pattern-binding))) + maybe-pattern-bindings))) + (unsupported-ids (filter identity + (map (lambda (category id) + (and (not category) id)) + categories ids)))) + (expand #`(capture-environment + module boxes var-ids + pattern-var-ids pattern-var-lvls + unsupported-ids) + r empty-wrap mod)))))))) + (global-extend 'core 'syntax (let () (define gen-syntax diff --git a/test-suite/standalone/test-loose-ends.c b/test-suite/standalone/test-loose-ends.c index 2fdbe7d..f815ae2 100644 --- a/test-suite/standalone/test-loose-ends.c +++ b/test-suite/standalone/test-loose-ends.c @@ -3,7 +3,7 @@ * Test items of the Guile C API that aren't covered by any other tests. */ -/* Copyright (C) 2009 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2012 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -43,9 +43,23 @@ test_scm_from_locale_keywordn () } static void +test_scm_local_eval () +{ + SCM result = scm_local_eval + (scm_list_3 (scm_from_latin1_symbol ("+"), + scm_from_latin1_symbol ("x"), + scm_from_latin1_symbol ("y")), + scm_c_eval_string ("(let ((x 1) (y 2)) (the-environment))")); + + assert (scm_is_true (scm_equal_p (result, + scm_from_signed_integer (3)))); +} + +static void tests (void *data, int argc, char **argv) { test_scm_from_locale_keywordn (); + test_scm_local_eval (); } int diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index a128cd7..0a587db 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,5 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -19,7 +19,8 @@ :use-module (test-suite lib) :use-module ((srfi srfi-1) :select (unfold count)) :use-module ((system vm vm) :select (make-vm call-with-vm)) - :use-module (ice-9 documentation)) + :use-module (ice-9 documentation) + :use-module (ice-9 local-eval)) (define exception:bad-expression @@ -422,4 +423,91 @@ (thunk (let loop () (cons 's (loop))))) (call-with-vm vm thunk)))) +;;; +;;; local-eval +;;; + +(with-test-prefix "local evaluation" + + (pass-if "local-eval" + (let* ((env1 (let ((x 1) (y 2) (z 3)) + (define-syntax-rule (foo x) (quote x)) + (the-environment))) + (env2 (local-eval '(let ((x 111) (a 'a)) + (define-syntax-rule (bar x) (quote x)) + (the-environment)) + env1))) + (local-eval '(set! x 11) env1) + (local-eval '(set! y 22) env1) + (local-eval '(set! z 33) env2) + (and (equal? (local-eval '(list x y z) env1) + '(11 22 33)) + (equal? (local-eval '(list x y z a) env2) + '(111 22 33 a))))) + + (pass-if "local-compile" + (let* ((env1 (let ((x 1) (y 2) (z 3)) + (define-syntax-rule (foo x) (quote x)) + (the-environment))) + (env2 (local-compile '(let ((x 111) (a 'a)) + (define-syntax-rule (bar x) (quote x)) + (the-environment)) + env1))) + (local-compile '(set! x 11) env1) + (local-compile '(set! y 22) env1) + (local-compile '(set! z 33) env2) + (and (equal? (local-compile '(list x y z) env1) + '(11 22 33)) + (equal? (local-compile '(list x y z a) env2) + '(111 22 33 a))))) + + (pass-if "the-environment within a macro" + (let ((module-a-name '(test module the-environment a)) + (module-b-name '(test module the-environment b))) + (let ((module-a (resolve-module module-a-name)) + (module-b (resolve-module module-b-name))) + (module-use! module-a (resolve-interface '(guile))) + (module-use! module-a (resolve-interface '(ice-9 local-eval))) + (eval '(begin + (define z 3) + (define-syntax-rule (test) + (let ((x 1) (y 2)) + (the-environment)))) + module-a) + (module-use! module-b (resolve-interface '(guile))) + (let ((env (eval `(let ((x 111) (y 222)) + ((@@ ,module-a-name test))) + module-b))) + (equal? (local-eval '(list x y z) env) + '(1 2 3)))))) + + (pass-if "capture pattern variables" + (let ((env (syntax-case #'(((a 1) (b 2) (c 3)) + ((d 4) (e 5) (f 6))) () + ((((k v) ...) ...) (the-environment))))) + (equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env)) + '((a b c 1 2 3) (d e f 4 5 6))))) + + (pass-if "mixed primitive-eval, local-eval and local-compile" + (let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3)) + (define-syntax-rule (foo x) (quote x)) + (the-environment)))) + (env2 (local-eval '(let ((x 111) (a 'a)) + (define-syntax-rule (bar x) (quote x)) + (the-environment)) + env1)) + (env3 (local-compile '(let ((y 222) (b 'b)) + (the-environment)) + env2))) + (local-eval '(set! x 11) env1) + (local-compile '(set! y 22) env2) + (local-eval '(set! z 33) env2) + (local-compile '(set! a (* y 2)) env3) + (and (equal? (local-compile '(list x y z) env1) + '(11 22 33)) + (equal? (local-eval '(list x y z a) env2) + '(111 22 33 444)) + (equal? (local-eval '(list x y z a b) env3) + '(111 222 33 444 b)))))) + ;;; eval.test ends here -- 1.7.5.4