/usr/share/racket/collects/syntax/to-string.rkt is in racket-common 6.1-4.
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 | (module to-string racket/base
(require racket/contract/base
syntax/stx)
(require racket/list)
(define (syntax->string c)
(let* ([s (open-output-string)]
[l (syntax->list c)]
[init-col (or (syntax-column (first l)) 0)]
[col init-col]
[line (or (syntax-line (first l)) 0)])
(define (advance c init-line!)
(let ([c (syntax-column c)]
[l (syntax-line c)])
(when (and l (l . > . line))
(newline)
(set! line l)
(init-line!))
(when c
(display (make-string (max 0 (- c col)) #\space))
(set! col c))))
(parameterize ([current-output-port s]
[read-case-sensitive #t])
(define (loop init-line!)
(lambda (c)
(cond
[(eq? 'code:blank (syntax-e c))
(advance c init-line!)]
[(eq? '_ (syntax-e c)) (void)]
[(eq? '... (syntax-e c))
(void)]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:comment))
(advance c init-line!)
(printf "; ")
(display (syntax-e (cadr (syntax->list c))))]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:contract))
(advance c init-line!)
(printf "; ")
(let* ([l (cdr (syntax->list c))]
[s-col (or (syntax-column (first l)) col)])
(set! col s-col)
(for-each (loop (lambda ()
(set! col s-col)
(printf "; ")))
l))]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'quote))
(advance c init-line!)
(printf "'")
(let ([i (cadr (syntax->list c))])
(set! col (or (syntax-column i) col))
((loop init-line!) i))]
[(pair? (syntax-e c))
(advance c init-line!)
(printf "(")
(set! col (+ col 1))
(map (loop init-line!) (syntax->list c))
(printf ")")
(set! col (+ col 1))]
[(vector? (syntax-e c))
(advance c init-line!)
(printf "#(")
(set! col (+ col 2))
(map (loop init-line!) (vector->list (syntax-e c)))
(printf ")")
(set! col (+ col 1))]
[else
(advance c init-line!)
(let ([s (format "~s" (syntax-e c))])
(set! col (+ col (string-length s)))
(display s))])))
(for-each (loop (lambda () (set! col init-col))) l))
(get-output-string s)))
(provide/contract [syntax->string (-> (and/c syntax? stx-list?)
string?)]))
|