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

some more reformatting etc, at all levels (and the schememodname went away, again -- will get it back soon with the lifting of requires)

Browse Source 
svn: r13649

original commit: 8f0edfd6d592cc8bfb9d72aca8629224dfa3b0d3
This commit is contained in:
Eli Barzilay 2009-02-16 02:53:01 +00:00
parent 8e9347bc09
commit b4f877bd45
1 changed files with 44 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -11,19 +11,19 @@
(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 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 ;; maps a block identifier to all identifiers that are used to define it
(define block-groups (make-free-identifier-mapping)) (define block-groups (make-free-identifier-mapping))
(define (get-block id) (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) (define (add-to-block! 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 block-groups id
(cons (syntax-local-introduce id) (mapping-get block-groups id))) (cons (syntax-local-introduce id) (mapping-get block-groups id)))
(free-identifier-mapping-put! (free-identifier-mapping-put!
code-blocks id chunks id
`(,@(mapping-get code-blocks id) ,@(map syntax-local-introduce exprs))))) `(,@(mapping-get chunks id) ,@(map syntax-local-introduce exprs)))))
(define-syntax (chunk stx) (define-syntax (chunk stx)
(syntax-case stx () (syntax-case stx ()
@ -35,7 +35,7 @@
#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-block! #'name (syntax->list #'(expr ...)))
#`(void)])])) #'(void)])]))
(define-syntax (tangle stx) (define-syntax (tangle stx)
(define block-mentions '()) (define block-mentions '())
@ -44,15 +44,15 @@
(append-map (append-map
(lambda (expr) (lambda (expr)
(if (identifier? expr) (if (identifier? expr)
(let ([subs (get-block expr)]) (let ([subs (get-block expr)])
(if (pair? subs) (if (pair? subs)
(begin (set! block-mentions (cons expr block-mentions)) (begin (set! block-mentions (cons expr block-mentions))
(loop subs)) (loop subs))
(list expr))) (list expr)))
(let ([subs (syntax->list expr)]) (let ([subs (syntax->list expr)])
(if subs (if subs
(list (loop subs)) (list (loop subs))
(list expr))))) (list expr)))))
block))) block)))
(with-syntax ([(body ...) body] (with-syntax ([(body ...) body]
;; construct arrows manually ;; construct arrows manually
@ -67,34 +67,33 @@
(define-syntax (module-begin stx) (define-syntax (module-begin stx)
(syntax-case stx () (syntax-case stx ()
[(module-begin expr ...) [(module-begin expr ...)
(let ([body-code (with-syntax
(let loop ([exprs (syntax->list #'(expr ...))]) ([(body-code ...)
(cond (let loop ([exprs (syntax->list #'(expr ...))])
[(null? exprs) null] (cond
[else [(null? exprs) null]
(let ([expanded [else
(local-expand (car exprs) (let ([expanded
'module (local-expand (car exprs)
(append (kernel-form-identifier-list) 'module
(syntax->list #'(provide (append (kernel-form-identifier-list)
require (syntax->list #'(provide
#%provide require
#%require))))]) #%provide
(syntax-case expanded (begin) #%require))))])
[(begin rest ...) (syntax-case expanded (begin)
(append (loop (syntax->list #'(rest ...))) [(begin rest ...)
(loop (cdr exprs)))] (append (loop (syntax->list #'(rest ...)))
[(id . rest) (loop (cdr exprs)))]
(ormap (lambda (kw) (free-identifier=? #'id kw)) [(id . rest)
(syntax->list #'(require (ormap (lambda (kw) (free-identifier=? #'id kw))
provide (syntax->list #'(require
chunk provide
#%require chunk
#%provide))) #%require
(cons expanded (loop (cdr exprs)))] #%provide)))
[else (loop (cdr exprs))]))]))]) (cons expanded (loop (cdr exprs)))]
[else (loop (cdr exprs))]))]))])
(with-syntax ([(body-code ...) body-code]) #'(#%module-begin
#'(#%module-begin body-code ...
body-code ... (tangle)))]))
(tangle))))]))