/usr/share/racket/collects/syntax/quote.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | #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]))
(define (convert e src-stx)
(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)
`#(#,(if src-stx
#`(unquote #,src-stx)
(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) #t)
s)))]
[else e])))
(syntax-case stx ()
[(_ #:source src-expr e)
(wrap #'e (convert #'e #'src-expr))]
[(_ e)
(wrap #'e (convert #'e #f))]))
|