/usr/share/racket/pkgs/source-syntax/source-syntax.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 86 | #lang racket/base
;; from Eli
(provide recover-source-syntax)
;; -------------------- utilities
(define (syntax-loc stx) (list (syntax-source stx) (syntax-position stx) (syntax-span stx)))
;; -------------------- the real stuff
;; Look for (the outermost) syntax in `orig' that has the same
;; location as `lookfor' which is coming from the expanded `orig',
;; given in `expanded'.
(define (recover-source-syntax orig expanded #:traverse-now? [now? #f])
(define src (syntax-source orig))
;; this maps source locations that are from orig to their syntax
(define syntax-locs (make-hash))
;; build `syntax-locs`
(let loop ([stx orig])
(when (and (syntax? stx)
;; avoid spurious hits in the table from syntaxes
;; that have no useful source information
(and (syntax-source stx)
(syntax-position stx)))
(hash-set! syntax-locs (syntax-loc stx) stx))
(let ([stx (if (syntax? stx) (syntax-e stx) stx)])
(when (pair? stx) (loop (car stx)) (loop (cdr stx)))))
;; this maps syntax from expanded to the original
(define parent-table (make-hasheq))
;; if `expanded` is mapped to something, then we'll start with it
(define initial-target
(hash-ref syntax-locs (syntax-loc expanded) #f))
;; this searches for lookfor in orig, building up the table as we go
;; add-to-table: stx or #f -> stx or #f
;; #f as `lookfor` indicates "traverse all of `expanded`
(define (add-to-table lookfor)
;; stx is expanded syntax, target is source syntax
(let loop ([stx expanded] [target initial-target])
(cond
[(syntax? stx)
(define new-target
;; check if `stx` has the same srcloc as something in orig
;; in which case it's a good target to use
;; otherwise keep using the old target
(hash-ref syntax-locs (syntax-loc stx) target))
;; map `stx` to the best enclosing syntax we have, if it's not already there
(hash-ref! parent-table stx new-target)
(cond
;; if we got what we came for, stop
[(and lookfor (eq? stx lookfor)) new-target]
;; take apart stx and loop on the components
[else
(let inner ([stxe (syntax-e stx)])
(cond [(list? stxe)
(for/or ([x (in-list stxe)])
(loop x new-target))]
[(pair? stxe) ; may be an improper syntax list
(or (loop (car stxe) new-target) (inner (cdr stxe)))]
[(syntax? stxe) ; base case
(loop stxe new-target)]
[else
#f]))])]
[else #f])))
;; if now?, add everything to the table
(when now?
(add-to-table #f))
(lambda (lookfor)
(or
;; we just might get a lookfor that is already in the original
(and (eq? src (syntax-source lookfor))
(hash-ref syntax-locs (syntax-loc lookfor) #f))
(hash-ref parent-table lookfor (λ ()
(cond [now? #f]
[else (add-to-table lookfor)
(hash-ref parent-table lookfor #f)]))))))
|