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