From 9412ea0707b079ad51c57930c4395236be72cfde Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 11 May 2012 13:12:16 -0600
Subject: [PATCH] add `syntax/quote' library

---
 collects/syntax/quote.rkt               | 80 +++++++++++++++++++++++++
 collects/syntax/scribblings/quote.scrbl | 17 ++++++
 2 files changed, 97 insertions(+)
 create mode 100644 collects/syntax/quote.rkt
 create mode 100644 collects/syntax/scribblings/quote.scrbl

diff --git a/collects/syntax/quote.rkt b/collects/syntax/quote.rkt
new file mode 100644
index 0000000000..6ae0aff5e0
--- /dev/null
+++ b/collects/syntax/quote.rkt
@@ -0,0 +1,80 @@
+#lang racket/base
+(require (for-syntax racket/base))
+
+(provide quote-syntax/keep-srcloc)
+
+(define-syntax (quote-syntax/keep-srcloc stx)
+  (define (wrap i n)
+    (cond
+     [(eq? i n) (let loop ([n n])
+                  (cond
+                   [(syntax? n) #`(quote-syntax #,n)]
+                   [(pair? n) #`(cons #,(loop (car n))
+                                      #,(loop (cdr n)))]
+                   [(box? n) #`(box #,(loop (unbox n)))]
+                   [(vector? n) #`(vector . #,(for/list ([i (in-vector n)])
+                                                (loop i)))]
+                   [(prefab-struct-key n)
+                    #`(make-prefab-struct '#,(prefab-struct-key n)
+                                          . #,(for/list ([i (in-list (cdr (vector->list 
+                                                                           (struct->vector n))))])
+                                                (loop i)))]
+                   [else #`(quote #,n)]))]
+     [else n]))
+  (syntax-case stx ()
+    [(_ e)
+     (wrap #'e
+           (let loop ([e #'e])
+             (cond
+              [(pair? e)
+               (define a (car e))
+               (define new-a (loop a))
+               (define b (cdr e))
+               (define new-b (loop b))
+               (if (and (eq? a new-a) (eq? b new-b))
+                   e
+                   #`(cons #,(wrap a new-a) #,(wrap b new-b)))]
+              [(vector? e)
+               (define new-vec (for/list ([i (in-vector e)])
+                                 (loop i)))
+               (if (for/and ([i (in-vector e)]
+                             [n (in-list new-vec)])
+                     (eq? i n))
+                   e
+                   #`(vector . #,(for/list ([i (in-vector e)]
+                                            [n (in-list new-vec)])
+                                   (wrap i n))))]
+              [(prefab-struct-key e)
+               (define l (cdr (vector->list (struct->vector e))))
+               (define new-l (for/list ([i (in-list l)])
+                               (loop i)))
+               (if (equal? l new-l)
+                   e
+                   #`(make-prefab-struct '#,(prefab-struct-key e)
+                                         . #,(for/list ([i (in-list l)]
+                                                        [n (in-list new-l)])
+                                               (wrap i n))))]
+              [(box? e)
+               (define a (unbox e))
+               (define new-a (loop a))
+               (if (eq? a new-a)
+                   e
+                   #`(box #,(wrap a new-a)))]
+              [(syntax? e)
+               (define v (syntax-e e))
+               (define new-v (loop v))
+               (if (and (eq? v new-v)
+                        (not (syntax-position e))
+                        (not (syntax-property e 'paren-shape)))
+                   e
+                   (let ([s #`(datum->syntax (quote-syntax #,(datum->syntax e 'ctx))
+                                             #,(wrap v new-v)
+                                             (quote #(#,(syntax-source e)
+                                                      #,(syntax-line e)
+                                                      #,(syntax-column e)
+                                                      #,(syntax-position e)
+                                                      #,(syntax-span e))))])
+                     (if (syntax-property e 'paren-shape)
+                         #`(syntax-property #,s 'paren-shape '#,(syntax-property e 'paren-shape))
+                         s)))]
+              [else e])))]))
diff --git a/collects/syntax/scribblings/quote.scrbl b/collects/syntax/scribblings/quote.scrbl
new file mode 100644
index 0000000000..4b26d28774
--- /dev/null
+++ b/collects/syntax/scribblings/quote.scrbl
@@ -0,0 +1,17 @@
+#lang scribble/manual
+@(require (for-label racket/base
+                     syntax/quote))
+
+@title{Preserving Source Locations}
+
+@defmodule[syntax/quote]{The @racketmodname[syntax/quote] module
+provides support for quoting syntax so that it's source locations
+are preserved in marshaled bytecode form.}
+
+@defform[(quote-syntax/keep-srcloc datum)]{
+
+Like @racket[(quote-syntax datum)], but the source locations of
+@racket[datum] are preserved.
+
+Unlike a @racket[quote-syntax] form, the results of evaluating the
+expression multiple times are not necessarily @racket[eq?].}