From 2be7d93637b6e32fe27b59306f5bb5362d1c6def Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Thu, 25 Dec 2008 16:33:50 -0500
Subject: [PATCH] =?UTF-8?q?-=20Added=20=20(syntax-transpose=20syntax-objec?=
 =?UTF-8?q?t=20base-id=20new-id-object).=20=20=20It=20returns=20syntax-obj?=
 =?UTF-8?q?ect=20wrapped=20with=20the=20marks=20and=20substitutions=20=20?=
 =?UTF-8?q?=20that=20have=20been=20added=20to=20new-id=20since=20its=20int?=
 =?UTF-8?q?roduction=20as=20base-id.=20=20=20The=20new-id=20and=20base-id?=
 =?UTF-8?q?=20should=20be=20free-identifier=3D=3F=20and=20new-id=20=20=20s?=
 =?UTF-8?q?hould=20have=20the=20same=20(or=20more)=20marks=20as=20base-id.?=

---
 scheme/last-revision       |  2 +-
 scheme/makefile.ss         |  1 +
 scheme/psyntax.expander.ss | 40 +++++++++++++++++++++++++++++++++++++-
 3 files changed, 41 insertions(+), 2 deletions(-)

diff --git a/scheme/last-revision b/scheme/last-revision
index a858d2d..1c38c90 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1724
+1725
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 68a343a..395745e 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -1314,6 +1314,7 @@
     [variable-transformer?                       i]
     [variable-transformer-procedure              i]
     [make-compile-time-value                     i]
+    [syntax-transpose                            i]
     [char-alphabetic?                            i r uc se]
     [char-ci<=?                                  i r uc se]
     [char-ci<?                                   i r uc se]
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index 81fc2ce..4f9bc26 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -32,7 +32,7 @@
           interaction-environment
           ellipsis-map assertion-error 
           environment environment? environment-symbols
-          new-interaction-environment)
+          new-interaction-environment syntax-transpose)
   (import
     (except (rnrs)
       environment environment? identifier?
@@ -2991,6 +2991,44 @@
               (make-stx (stx-expr x) (append diff (stx-mark* x)) '() '()))
             id-vec))))
 
+  (define (syntax-transpose object base-id new-id)
+    (define who 'syntax-transpose)
+    (define (err msg . args) (apply assertion-violation who msg args))
+    (define (split s*)
+      (cond
+        [(eq? (car s*) 'shift) 
+         (values (list 'shift) (cdr s*))]
+        [else
+         (let-values ([(s1* s2*) (split (cdr s*))])
+           (values (cons (car s*) s1*) s2*))]))
+    (define (final s*)
+      (cond
+        [(or (null? s*) (eq? (car s*) 'shift)) '()]
+        [else (cons (car s*) (final (cdr s*)))]))
+    (define (diff m m* s* ae*)
+      (if (null? m*)
+          (err "unmatched identifiers" base-id new-id)
+          (let ([m1 (car m*)])
+            (if (eq? m m1)
+                (values '() (final s*) '())
+                (let-values ([(s1* s2*) (split s*)])
+                (let-values ([(nm* ns* nae*)
+                              (diff m (cdr m*) s2* (cdr ae*))])
+                  (values (cons m1 nm*) 
+                          (append s1* ns*)
+                          (cons (car ae*) nae*))))))))
+    (unless (id? base-id) (err "not an identifier" base-id))
+    (unless (id? new-id) (err "not an identifier" new-id))
+    (unless (free-identifier=? base-id new-id)
+      (err "not the same identifier" base-id new-id))
+    (let-values ([(m* s* ae*)
+                  (diff (car (stx-mark* base-id))
+                    (stx-mark* new-id)
+                    (stx-subst* new-id)
+                    (stx-ae* new-id))])
+      (if (and (null? m*) (null? s*))
+          object
+          (mkstx object m* s* ae*))))
 
   (define chi-internal-module
     (lambda (e r mr lex* rhs* mod** kwd*)