suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

avoid resolving module-path-index (current-directory may not be set right)

Browse Source
This commit is contained in:
Ryan Culpepper 2011-12-12 17:39:18 -07:00
parent 1ec2f9ca82
commit 32c5e3c9d2
1 changed files with 15 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/unstable/wrapc.rkt
View File

@ -4,6 +4,7 @@
racket/contract/base racket/contract/base
syntax/location) syntax/location)
syntax/srcloc syntax/srcloc
syntax/modcollapse
racket/syntax) racket/syntax)
(provide/contract (provide/contract
@ -71,17 +72,20 @@
(if (syntax? ctx) (if (syntax? ctx)
(get-source-expr (extract-source ctx) #f) (get-source-expr (extract-source ctx) #f)
(get-source-expr 'unknown #f))] (get-source-expr 'unknown #f))]
[else [(string? source) #`(quote #,source)]
(let ([source-string [(syntax? source) #`(quote #,(source-location->string source))]
(cond [(string? source) source] [(module-path-index? source)
[(syntax? source) (source-location->string source)] ;; FIXME: extend collapse-module-path-index to accept #f, return rel mod path
[(module-path-index? source) (let* ([here (current-load-relative-directory)]
;; FIXME: share with syntax/location ?? [collapsed
(let ([name (resolved-module-path-name (collapse-module-path-index source (or here (build-path 'same)))])
(module-path-index-resolve source))]) (cond [(and (path? collapsed) here)
(cond [(path? name) (format "(file ~s)" (path->string name))] #`(quote #,(path->string collapsed))]
[(symbol? name) (format "(quote ~s)" name)]))])]) [(path? collapsed)
#`(quote #,source-string))])) (let-values ([(rel base) (module-path-index-split source)])
#`(quote #,rel))]
[else
#`(quote #,(format "~s" collapsed))]))]))
(define (extract-source stx) (define (extract-source stx)
(let ([id (syntax-case stx () (let ([id (syntax-case stx ()