commit b4f877bd4544ec1ff1bce0395f4aee9c1cc68d82
parent 8e9347bc09a81b6854b591077529935e18cad11d
Author: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 16 Feb 2009 02:53:01 +0000
some more reformatting etc, at all levels (and the schememodname went away, again -- will get it back soon with the lifting of requires)
svn: r13649
original commit: 8f0edfd6d592cc8bfb9d72aca8629224dfa3b0d3
Diffstat:
1 file changed, 44 insertions(+), 45 deletions(-)
diff --git a/collects/games/chat-noir/literate-lang.ss b/collects/games/chat-noir/literate-lang.ss
@@ -11,19 +11,19 @@
(define (mapping-get mapping id)
(free-identifier-mapping-get mapping id (lambda () '())))
;; maps a block identifier to its collected expressions
- (define code-blocks (make-free-identifier-mapping))
+ (define chunks (make-free-identifier-mapping))
;; maps a block identifier to all identifiers that are used to define it
(define block-groups (make-free-identifier-mapping))
(define (get-block id)
- (map syntax-local-introduce (mapping-get code-blocks id)))
+ (map syntax-local-introduce (mapping-get chunks id)))
(define (add-to-block! id exprs)
(unless main-id (set! main-id id))
(free-identifier-mapping-put!
block-groups id
(cons (syntax-local-introduce id) (mapping-get block-groups id)))
(free-identifier-mapping-put!
- code-blocks id
- `(,@(mapping-get code-blocks id) ,@(map syntax-local-introduce exprs)))))
+ chunks id
+ `(,@(mapping-get chunks id) ,@(map syntax-local-introduce exprs)))))
(define-syntax (chunk stx)
(syntax-case stx ()
@@ -35,7 +35,7 @@
#f "chunk names must begin and end with angle brackets, <...>"
stx #'name)]
[else (add-to-block! #'name (syntax->list #'(expr ...)))
- #`(void)])]))
+ #'(void)])]))
(define-syntax (tangle stx)
(define block-mentions '())
@@ -44,15 +44,15 @@
(append-map
(lambda (expr)
(if (identifier? expr)
- (let ([subs (get-block expr)])
- (if (pair? subs)
- (begin (set! block-mentions (cons expr block-mentions))
- (loop subs))
- (list expr)))
- (let ([subs (syntax->list expr)])
- (if subs
- (list (loop subs))
- (list expr)))))
+ (let ([subs (get-block expr)])
+ (if (pair? subs)
+ (begin (set! block-mentions (cons expr block-mentions))
+ (loop subs))
+ (list expr)))
+ (let ([subs (syntax->list expr)])
+ (if subs
+ (list (loop subs))
+ (list expr)))))
block)))
(with-syntax ([(body ...) body]
;; construct arrows manually
@@ -67,34 +67,33 @@
(define-syntax (module-begin stx)
(syntax-case stx ()
[(module-begin expr ...)
- (let ([body-code
- (let loop ([exprs (syntax->list #'(expr ...))])
- (cond
- [(null? exprs) null]
- [else
- (let ([expanded
- (local-expand (car exprs)
- 'module
- (append (kernel-form-identifier-list)
- (syntax->list #'(provide
- require
- #%provide
- #%require))))])
- (syntax-case expanded (begin)
- [(begin rest ...)
- (append (loop (syntax->list #'(rest ...)))
- (loop (cdr exprs)))]
- [(id . rest)
- (ormap (lambda (kw) (free-identifier=? #'id kw))
- (syntax->list #'(require
- provide
- chunk
- #%require
- #%provide)))
- (cons expanded (loop (cdr exprs)))]
- [else (loop (cdr exprs))]))]))])
-
- (with-syntax ([(body-code ...) body-code])
- #'(#%module-begin
- body-code ...
- (tangle))))]))
+ (with-syntax
+ ([(body-code ...)
+ (let loop ([exprs (syntax->list #'(expr ...))])
+ (cond
+ [(null? exprs) null]
+ [else
+ (let ([expanded
+ (local-expand (car exprs)
+ 'module
+ (append (kernel-form-identifier-list)
+ (syntax->list #'(provide
+ require
+ #%provide
+ #%require))))])
+ (syntax-case expanded (begin)
+ [(begin rest ...)
+ (append (loop (syntax->list #'(rest ...)))
+ (loop (cdr exprs)))]
+ [(id . rest)
+ (ormap (lambda (kw) (free-identifier=? #'id kw))
+ (syntax->list #'(require
+ provide
+ chunk
+ #%require
+ #%provide)))
+ (cons expanded (loop (cdr exprs)))]
+ [else (loop (cdr exprs))]))]))])
+ #'(#%module-begin
+ body-code ...
+ (tangle)))]))
