/usr/share/racket/collects/syntax/location.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 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | #lang racket/base
(require syntax/srcloc
(for-syntax racket/base syntax/srcloc setup/path-to-relative))
(provide (protect-out module-name-fixup)
quote-srcloc
quote-srcloc-string
quote-srcloc-prefix
quote-source-file
quote-line-number
quote-column-number
quote-character-position
quote-character-span
quote-module-path
quote-module-name)
(begin-for-syntax
(define (source-location-relative-source loc)
(define src (source-location-source loc))
(and (path-string? src)
(path->relative-string/library src #f)))
(define (syntax-quote-source stx)
(cond
[(source-location-relative-source stx)
=>
(lambda (rel) #`(quote #,rel))]
[else #`(source-location-source
(quote-syntax
#,(identifier-prune-to-source-module
(datum->syntax stx 'here stx stx))))]))
(define (syntax-quote-line stx) #`(quote #,(syntax-line stx)))
(define (syntax-quote-column stx) #`(quote #,(syntax-column stx)))
(define (syntax-quote-position stx) #`(quote #,(syntax-position stx)))
(define (syntax-quote-span stx) #`(quote #,(syntax-span stx)))
(define (syntax-quote-srcloc stx)
#`(srcloc
#,(syntax-quote-source stx)
#,(syntax-quote-line stx)
#,(syntax-quote-column stx)
#,(syntax-quote-position stx)
#,(syntax-quote-span stx)))
(define (syntax-quote-string stx)
(cond
[(source-location-relative-source stx)
#`(quote #,(source-location->string stx))]
[else
#`(source-location->string
#,(syntax-quote-srcloc stx))]))
(define (syntax-quote-prefix stx)
(cond
[(source-location-relative-source stx)
#`(quote #,(source-location->prefix stx))]
[else
#`(source-location->prefix
#,(syntax-quote-srcloc stx))]))
(define (source-transformer proc)
(lambda (stx)
(syntax-case stx ()
[(_) (proc stx)]
[(_ here) (proc #'here)]))))
(define-syntax quote-srcloc
(source-transformer syntax-quote-srcloc))
(define-syntax quote-source-file
(source-transformer syntax-quote-source))
(define-syntax quote-line-number
(source-transformer syntax-quote-line))
(define-syntax quote-column-number
(source-transformer syntax-quote-column))
(define-syntax quote-character-position
(source-transformer syntax-quote-position))
(define-syntax quote-character-span
(source-transformer syntax-quote-span))
(define-syntax quote-srcloc-string
(source-transformer syntax-quote-string))
(define-syntax quote-srcloc-prefix
(source-transformer syntax-quote-prefix))
(define (variable-reference->module-source/submod vr)
(define src (variable-reference->module-source vr))
(define rname (variable-reference->resolved-module-path vr))
(define name (and rname (resolved-module-path-name rname)))
(if (pair? name)
(cons src (cdr name))
src))
(define-syntax-rule (module-source)
(variable-reference->module-source/submod
(#%variable-reference)))
(define-for-syntax (do-quote-module stx fixup)
(syntax-case stx ()
[(_ path ...)
(for ([path (in-list (syntax->list #'(path ...)))]
[i (in-naturals)])
(unless (or (symbol? (syntax-e path))
(equal? (syntax-e path) ".."))
(raise-syntax-error #f "not a submodule path element" stx path)))
(with-syntax ([fixup fixup])
#'(fixup (module-source) (list 'path ...)))]))
(define-syntax (quote-module-name stx)
(do-quote-module stx #'module-name-fixup))
(define (module-name-fixup src path)
(do-fixup src path #f))
(define-syntax (quote-module-path stx)
(do-quote-module stx #'module-path-fixup))
(define (module-path-fixup src path)
(do-fixup src path #t))
(define (do-fixup src path as-modpath?)
(define (last-pass src)
(cond
[(path? src) src]
[(symbol? src) (if as-modpath?
`(quote ,src)
src)]
[(list? src)
(define base (last-pass (car src)))
(define sm (cdr src))
(if as-modpath?
`(submod ,base ,@sm)
(cons base sm))]
[else 'top-level]))
(last-pass
(cond
[(null? path) src]
[(pair? src) (append src path)]
[else (cons src path)])))
|