suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

fix srcloc and binding tracking in scribble/lp

Browse Source 
svn: r13849

original commit: 9df218784ad23abb98be72d2eef03d03ef2fa899
This commit is contained in:
Matthew Flatt 2009-02-26 13:40:59 +00:00
parent de160f7842
commit 513a508dc4
1 changed files with 8 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/scribble/lp/lang/lang.ss
View File

@ -3,7 +3,8 @@
(provide (except-out (all-from-out scheme/base) #%module-begin) (provide (except-out (all-from-out scheme/base) #%module-begin)
(rename-out [module-begin #%module-begin])) (rename-out [module-begin #%module-begin]))
(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase)) (require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase
syntax/strip-context))
(begin-for-syntax (begin-for-syntax
(define first-id #f) (define first-id #f)
@ -14,17 +15,16 @@
(define chunks (make-free-identifier-mapping)) (define chunks (make-free-identifier-mapping))
;; maps a chunk identifier to all identifiers that are used to define it ;; maps a chunk identifier to all identifiers that are used to define it
(define chunk-groups (make-free-identifier-mapping)) (define chunk-groups (make-free-identifier-mapping))
(define (get-chunk id) (define (get-chunk id) (mapping-get chunks id))
(map syntax-local-introduce (mapping-get chunks id)))
(define (add-to-chunk! id exprs) (define (add-to-chunk! id exprs)
(unless first-id (set! first-id id)) (unless first-id (set! first-id id))
(when (eq? (syntax-e id) '<*>) (set! main-id id)) (when (eq? (syntax-e id) '<*>) (set! main-id id))
(free-identifier-mapping-put! (free-identifier-mapping-put!
chunk-groups id chunk-groups id
(cons (syntax-local-introduce id) (mapping-get chunk-groups id))) (cons id (mapping-get chunk-groups id)))
(free-identifier-mapping-put! (free-identifier-mapping-put!
chunks id chunks id
`(,@(mapping-get chunks id) ,@(map syntax-local-introduce exprs))))) `(,@(mapping-get chunks id) ,@exprs))))
(define-syntax (tangle stx) (define-syntax (tangle stx)
(define chunk-mentions '()) (define chunk-mentions '())
@ -53,7 +53,8 @@
[((b-use b-id) ...) [((b-use b-id) ...)
(append-map (lambda (m) (append-map (lambda (m)
(map (lambda (u) (map (lambda (u)
(list m (syntax-local-introduce u))) (list (syntax-local-introduce m)
(syntax-local-introduce u)))
(mapping-get chunk-groups m))) (mapping-get chunk-groups m)))
chunk-mentions)]) chunk-mentions)])
#`(begin body ... (let ([b-id (void)]) b-use) ...))) #`(begin body ... (let ([b-id (void)]) b-use) ...)))
@ -77,7 +78,7 @@
[(_ id exprs . body) [(_ id exprs . body)
(let ([expanded (let ([expanded
(expand `(,#'module scribble-lp-tmp-name scribble/private/lp (expand `(,#'module scribble-lp-tmp-name scribble/private/lp
,@(syntax->datum #'(id exprs . body))))]) ,@(strip-context #'(id exprs . body))))])
(syntax-case expanded () (syntax-case expanded ()
[(module name lang (mb . stuff)) [(module name lang (mb . stuff))
(begin (extract-chunks #'stuff) (begin (extract-chunks #'stuff)