unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* local-eval on syntax-local-binding, bound-identifiers
@ 2012-01-15 22:17 Andy Wingo
  2012-01-16  3:30 ` Mark H Weaver
  0 siblings, 1 reply; 9+ messages in thread
From: Andy Wingo @ 2012-01-15 22:17 UTC (permalink / raw)
  To: Mark H. Weaver; +Cc: guile-devel

[-- Attachment #1: Type: text/plain, Size: 791 bytes --]

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


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-add-syntax-local-binding.patch --]
[-- Type: text/x-diff, Size: 4372 bytes --]

From 48d8e52e316984f2bf9380df85079bb5fa142253 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
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


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-add-bound-identifiers.patch --]
[-- Type: text/x-diff, Size: 3836 bytes --]

From 2c3da44320019453115811af386febaa7eb241c3 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
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


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0003-Implement-local-eval-local-compile-and-the-environme.patch --]
[-- Type: text/x-diff, Size: 17213 bytes --]

From ddea51310227155e3771c3e6acbbecf24dc74c42 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
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
 
 \f
 
+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 "#<lexical-environment ~S (~S bindings)>"
+           (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


[-- Attachment #5: Type: text/plain, Size: 27 bytes --]



-- 
http://wingolog.org/

^ permalink raw reply related	[flat|nested] 9+ messages in thread

end of thread, other threads:[~2012-01-19 11:55 UTC | newest]

Thread overview: 9+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2012-01-15 22:17 local-eval on syntax-local-binding, bound-identifiers Andy Wingo
2012-01-16  3:30 ` Mark H Weaver
2012-01-16 11:01   ` Andy Wingo
2012-01-16 13:28     ` Mark H Weaver
2012-01-16 15:17       ` Andy Wingo
2012-01-16 20:36         ` Mark H Weaver
2012-01-16 23:27           ` Andy Wingo
2012-01-17 10:55             ` David Kastrup
2012-01-19 11:55             ` Andy Wingo

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).