From 09ba44abeb47cdf4ec61df6f7386217f0cbe30c7 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 15 Jan 2012 17:51:02 +0100
Subject: [PATCH] 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 lexially bound identifier (a lexical, local macro, or pattern
  variable).
---
 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..dcabafe 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
+                       (error "what!!!"))))
+               (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 (not b)
+                       (error "displaced lexical" id))
+                   (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)))))))))
+
     (set! generate-temporaries
           (lambda (ls)
             (arg-check list? ls 'generate-temporaries)
-- 
1.7.8.3