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

Added a module for statically computing source locations and module paths.

Browse Source 
svn: r17722
This commit is contained in:
Carl Eastlund 2010-01-18 23:10:10 +00:00
parent 54d5b0ac7f
commit f346bc7f1a
1 changed files with 66 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/unstable/location.ss Normal file
View File

@ -0,0 +1,66 @@
#lang scheme/base
(require (for-syntax scheme/base unstable/srcloc))
(provide quote-srcloc
quote-source-file
quote-line-number
quote-column-number
quote-character-position
quote-character-span
quote-module-path
quote-module-name)
(define-syntax (quote-srcloc stx)
(syntax-case stx ()
[(_) #`(quote-srcloc #,stx)]
[(_ loc)
(with-syntax ([(arg ...) (build-source-location-list #'loc)])
#'(make-srcloc (quote arg) ...))]))
(define-syntax (quote-source-file stx)
(syntax-case stx ()
[(_) #`(quote-source-file #,stx)]
[(_ loc) #`(quote #,(source-location-source #'loc))]))
(define-syntax (quote-line-number stx)
(syntax-case stx ()
[(_) #`(quote-line-number #,stx)]
[(_ loc) #`(quote #,(source-location-line #'loc))]))
(define-syntax (quote-column-number stx)
(syntax-case stx ()
[(_) #`(quote-column-number #,stx)]
[(_ loc) #`(quote #,(source-location-column #'loc))]))
(define-syntax (quote-character-position stx)
(syntax-case stx ()
[(_) #`(quote-character-position #,stx)]
[(_ loc) #`(quote #,(source-location-position #'loc))]))
(define-syntax (quote-character-span stx)
(syntax-case stx ()
[(_) #`(quote-character-span #,stx)]
[(_ loc) #`(quote #,(source-location-span #'loc))]))
(define-syntax-rule (quote-module-name)
(variable-reference->module-name (#%variable-reference)))
(define-syntax-rule (quote-module-path)
(variable-reference->module-path (#%variable-reference)))
(define (variable-reference->module-path var)
(module-name->module-path
(variable-reference->module-name var)))
(define (variable-reference->module-name var)
(let* ([rmp (variable-reference->resolved-module-path var)])
(if (resolved-module-path? rmp)
(resolved-module-path-name rmp)
rmp)))
(define (module-name->module-path name)
(cond
[(path? name) `(file ,(path->string name))]
[(symbol? name) `(quote ,name)]
[else 'top-level]))