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

finished fixing multiple chunks

Browse Source 
svn: r13841
This commit is contained in:
Robby Findler 2009-02-25 20:35:38 +00:00
parent 973f08e011
commit 42adbca527
2 changed files with 54 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/games/chat-noir/README
View File

@ -4,10 +4,6 @@ Games.
Problems: Problems:
- handling multiple chunks is broken right now, so the
chunkref-introducting macro (in scribble/private/lp.ss)
is disabled.
- Need to make 'a-chunk' be a real macro, I expect. (used in - Need to make 'a-chunk' be a real macro, I expect. (used in
scribble/private/lp.ss) scribble/private/lp.ss)
@ -15,8 +11,6 @@ Problems:
- do unbound chunk ids signal syntax errors? How about unused ones? - do unbound chunk ids signal syntax errors? How about unused ones?
- toc entries should not be underlined.
To document: To document:
@chunk @chunk

107
collects/scribble/private/lp.ss
View File

@ -7,73 +7,74 @@
;; maps chunk identifiers to a counter, so we can distinguish multiple uses ;; maps chunk identifiers to a counter, so we can distinguish multiple uses
;; of the same name ;; of the same name
(define chunk-numbers (make-free-identifier-mapping)) (define chunk-numbers (make-free-identifier-mapping))
(define (get-chunk-number id install?) (define (get-chunk-number id)
(let ([n (add1 (free-identifier-mapping-get chunk-numbers id (free-identifier-mapping-get chunk-numbers id (lambda () #f)))
(lambda () 0)))]) (define (inc-chunk-number id)
(when install? (free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id))))
(free-identifier-mapping-put! chunk-numbers id n)) (define (init-chunk-number id)
n)) (free-identifier-mapping-put! chunk-numbers id 2)))
(define (register-chunk-name name)
(get-chunk-number name #t)))
(define-syntax (chunk stx) (define-syntax (chunk stx)
(syntax-case stx () (syntax-case stx ()
[(_ name expr ...) [(_ name expr ...)
;; no need for more error checking, using chunk for the code will do that ;; no need for more error checking, using chunk for the code will do that
(identifier? #'name) (identifier? #'name)
(let ([n (get-chunk-number (syntax-local-introduce #'name) #f)] (let* ([n (get-chunk-number (syntax-local-introduce #'name))]
[str (symbol->string (syntax-e #'name))]) [str (symbol->string (syntax-e #'name))]
[tag (format "~a:~a" str (or n 1))])
(when n
(inc-chunk-number (syntax-local-introduce #'name)))
(syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...))) (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr ...)))
(if (n . > . 1) (with-syntax ([tag tag]
(let ([str [str str]
(format [((for-label-mod ...) ...)
"need to handle secondary tags: ~a ~a\n" (map (lambda (expr)
n (syntax-case expr (require)
str)]) [(require mod ...)
#`(begin (let loop ([mods (syntax->list #'(mod ...))])
(italic #,str))) (cond
(with-syntax ([tag str] [(null? mods) null]
[str str] [else
[((for-label-mod ...) ...) (syntax-case (car mods) (for-syntax)
(map (lambda (expr) [(for-syntax x ...)
(syntax-case expr (require) (append (loop (syntax->list #'(x ...)))
[(require mod ...) (loop (cdr mods)))]
(let loop ([mods (syntax->list #'(mod ...))]) [x
(cond (cons #'x (loop (cdr mods)))])]))]
[(null? mods) null] [else null]))
[else (syntax->list #'(expr ...)))]
(syntax-case (car mods) (for-syntax)
[(for-syntax x ...) [(rest ...) (if n
(loop (cdr mods)) #`((subscript #,(format "~a" n)))
#; #`())])
(append (loop (syntax->list #'(x ...)))
(loop (cdr mods)))] #`(begin
[x (require (for-label for-label-mod ... ...))
(cons #'x (loop (cdr mods)))])]))] #,@(if n
[else null])) #'()
(syntax->list #'(expr ...)))]) #'((define-syntax name (make-element-id-transformer
#`(begin (lambda (stx) #'(chunkref name))))
(require (for-label for-label-mod ... ...)) (begin-for-syntax (init-chunk-number #'name))))
(define-syntax name (make-element-id-transformer (make-splice
(lambda (stx) #'(chunkref name)))) (list (make-toc-element
(begin-for-syntax (register-chunk-name #'name)) #f
(make-splice (list (elemtag '(chunk tag)
(list (make-toc-element (bold (italic (scheme name)) " ::=")))
#f (list (smaller (elemref '(chunk tag) #:underline? #f
(list (elemtag '(chunk tag) str
(bold (italic (scheme name)) " ::="))) rest ...))))
(list (smaller (elemref '(chunk tag) #:underline? #f (schemeblock expr ...))))))]))
str))))
(schemeblock expr ...)))))))]))
(define-syntax (chunkref stx) (define-syntax (chunkref stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ id)
(identifier? #'id) (identifier? #'id)
(with-syntax ([str (format "~a" (syntax-e #'id))]) (with-syntax ([tag (format "~a:1" (syntax-e #'id))]
#'(elemref '(chunk str) #:underline? #f str))])) [str (format "~a" (syntax-e #'id))])
#'(elemref '(chunk tag) #:underline? #f str))]))
(provide (all-from-out scheme/base (provide (all-from-out scheme/base