63 lines
2.1 KiB
Scheme
63 lines
2.1 KiB
Scheme
(module contract-helpers mzscheme
|
|
|
|
(provide module-source-as-symbol build-src-loc-string mangle-id)
|
|
|
|
;; mangle-id : syntax string syntax ... -> syntax
|
|
;; constructs a mangled name of an identifier from an identifier
|
|
;; the name isn't fresh, so `id' combined with `ids' must already be unique.
|
|
(define (mangle-id main-stx prefix id . ids)
|
|
(datum->syntax-object
|
|
#f
|
|
(string->symbol
|
|
(string-append
|
|
prefix
|
|
(format
|
|
"-~a~a"
|
|
(syntax-object->datum id)
|
|
(apply
|
|
string-append
|
|
(map
|
|
(lambda (id)
|
|
(format "-~a" (syntax-object->datum id)))
|
|
ids)))))))
|
|
|
|
;; build-src-loc-string : syntax -> (union #f string)
|
|
(define (build-src-loc-string stx)
|
|
(let ([source (syntax-source stx)]
|
|
[line (syntax-line stx)]
|
|
[col (syntax-column stx)]
|
|
[pos (syntax-position stx)])
|
|
(cond
|
|
[(and (path? source) line col)
|
|
(format "~a:~a:~a" (path->string source) line col)]
|
|
[(and (string? source) line col)
|
|
(format "~a:~a:~a" source line col)]
|
|
[(and line col)
|
|
(format "~a:~a" line col)]
|
|
[(and (string? source) pos)
|
|
(format "~a:~a" source pos)]
|
|
[(and (path? source) pos)
|
|
(format "~a:~a" (path->string source) pos)]
|
|
[pos
|
|
(format "~a" pos)]
|
|
[else #f])))
|
|
|
|
(define o (current-output-port))
|
|
|
|
;; module-source-as-symbol : syntax -> symbol
|
|
;; constructs a symbol for use in the blame error messages
|
|
;; when blaming the module where stx's occurs.
|
|
(define (module-source-as-symbol stx)
|
|
(let ([src-module (syntax-source-module stx)])
|
|
(cond
|
|
[(symbol? src-module) src-module]
|
|
[(module-path-index? src-module)
|
|
(let-values ([(path base) (module-path-index-split src-module)])
|
|
;; we dont' normalize here, because we don't
|
|
;; want to assume that the collection paths
|
|
;; are set or the file system can be accessed.
|
|
(if path
|
|
(string->symbol (format "~s" path))
|
|
'top-level))]
|
|
[else 'top-level]))))
|