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

better names

Browse Source 
svn: r13652

original commit: f9897212f00d1fd8ce3ecf3bdeeb22eae5d7b4f7
This commit is contained in:
Eli Barzilay 2009-02-16 03:22:09 +00:00
parent c62039efce
commit 0752d0eb55
1 changed files with 14 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/games/chat-noir/literate-lang.ss
View File

@ -10,17 +10,17 @@
(define main-id #f) (define main-id #f)
(define (mapping-get mapping id) (define (mapping-get mapping id)
(free-identifier-mapping-get mapping id (lambda () '()))) (free-identifier-mapping-get mapping id (lambda () '())))
;; maps a block identifier to its collected expressions ;; maps a chunk identifier to its collected expressions
(define chunks (make-free-identifier-mapping)) (define chunks (make-free-identifier-mapping))
;; maps a block identifier to all identifiers that are used to define it ;; maps a chunk identifier to all identifiers that are used to define it
(define block-groups (make-free-identifier-mapping)) (define chunk-groups (make-free-identifier-mapping))
(define (get-block id) (define (get-chunk id)
(map syntax-local-introduce (mapping-get chunks id))) (map syntax-local-introduce (mapping-get chunks id)))
(define (add-to-block! id exprs) (define (add-to-chunk! id exprs)
(unless main-id (set! main-id id)) (unless main-id (set! main-id id))
(free-identifier-mapping-put! (free-identifier-mapping-put!
block-groups id chunk-groups id
(cons (syntax-local-introduce id) (mapping-get block-groups id))) (cons (syntax-local-introduce 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) ,@(map syntax-local-introduce exprs)))))
@ -34,19 +34,19 @@
(raise-syntax-error (raise-syntax-error
#f "chunk names must begin and end with angle brackets, <...>" #f "chunk names must begin and end with angle brackets, <...>"
stx #'name)] stx #'name)]
[else (add-to-block! #'name (syntax->list #'(expr ...))) [else (add-to-chunk! #'name (syntax->list #'(expr ...)))
#'(void)])])) #'(void)])]))
(define-syntax (tangle stx) (define-syntax (tangle stx)
(define block-mentions '()) (define chunk-mentions '())
(define body (define body
(let loop ([block (get-block main-id)]) (let loop ([block (get-chunk main-id)])
(append-map (append-map
(lambda (expr) (lambda (expr)
(if (identifier? expr) (if (identifier? expr)
(let ([subs (get-block expr)]) (let ([subs (get-chunk expr)])
(if (pair? subs) (if (pair? subs)
(begin (set! block-mentions (cons expr block-mentions)) (begin (set! chunk-mentions (cons expr chunk-mentions))
(loop subs)) (loop subs))
(list expr))) (list expr)))
(let ([subs (syntax->list expr)]) (let ([subs (syntax->list expr)])
@ -60,8 +60,8 @@
(append-map (lambda (m) (append-map (lambda (m)
(map (lambda (u) (map (lambda (u)
(list m (syntax-local-introduce u))) (list m (syntax-local-introduce u)))
(mapping-get block-groups m))) (mapping-get chunk-groups m)))
block-mentions)]) chunk-mentions)])
#`(begin body ... (let ([b-id (void)]) b-use) ...))) #`(begin body ... (let ([b-id (void)]) b-use) ...)))
(define-syntax (module-begin stx) (define-syntax (module-begin stx)