96 lines
3.1 KiB
Scheme
96 lines
3.1 KiB
Scheme
(module contract-helpers mzscheme
|
|
|
|
(provide module-source-as-symbol build-src-loc-string mangle-id
|
|
build-struct-names
|
|
nums-up-to)
|
|
|
|
;; 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])))
|
|
|
|
|
|
(define build-struct-names
|
|
(lambda (name-stx fields omit-sel? omit-set? srcloc-stx)
|
|
(let ([name (symbol->string (syntax-e name-stx))]
|
|
[fields (map symbol->string (map syntax-e fields))]
|
|
[+ string-append])
|
|
(map (lambda (s)
|
|
(datum->syntax-object name-stx (string->symbol s) srcloc-stx))
|
|
(append
|
|
(list
|
|
(+ "struct:" name)
|
|
(+ "make-" name)
|
|
(+ name "?"))
|
|
(let loop ([l fields])
|
|
(if (null? l)
|
|
null
|
|
(append
|
|
(if omit-sel?
|
|
null
|
|
(list (+ name "-" (car l))))
|
|
(if omit-set?
|
|
null
|
|
(list (+ "set-" name "-" (car l) "!")))
|
|
(loop (cdr l))))))))))
|
|
|
|
(define (nums-up-to n)
|
|
(let loop ([i 0])
|
|
(cond
|
|
[(= i n) '()]
|
|
[else (cons i (loop (+ i 1)))]))))
|