mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-25 12:40:26 +02:00
Code Activity

Implement local-eval', local-compile', and `the-environment'

Browse source 
* 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 <mhw@netris.org>.
This commit is contained in:
Andy Wingo 2012-01-03 04:02:08 -05:00
parent f5e772b2ba
commit d062a8c1ee
7 changed files with 411 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

34
doc/ref/api-evaluation.texi
View file

@ -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:

13
libguile/debug.c
View file

@ -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_public_variable ("ice-9 local-eval", "local-eval");
return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env);
}
static void
init_stack_limit (void)
{

4
libguile/debug.h
View file

@ -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);

5
module/Makefile.am
View file

@ -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 \

251
module/ice-9/local-eval.scm Normal file
View file

@ -0,0 +1,251 @@
;;; -*- 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)
#:use-module (system syntax)
#: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)))

16
test-suite/standalone/test-loose-ends.c
View file

@ -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
@ -42,10 +42,24 @@ test_scm_from_locale_keywordn ()
assert (scm_is_true (scm_keyword_p (kw)));
}
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

95
test-suite/tests/eval.test
View file

@ -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