commit 8f086861ee2a8e86e6f4a0369c9b1588d6627d39
parent a9198c9c9e676aa8585506c7c8cf5ff1a36ba46c
Author: Robby Findler <robby@racket-lang.org>
Date: Wed, 25 Feb 2009 20:35:38 +0000
finished fixing multiple chunks
svn: r13841
original commit: 42adbca52765002306d46df8f660b8eb6f088a1b
Diffstat:
1 file changed, 54 insertions(+), 53 deletions(-)
diff --git a/collects/scribble/private/lp.ss b/collects/scribble/private/lp.ss
@@ -7,73 +7,74 @@
;; maps chunk identifiers to a counter, so we can distinguish multiple uses
;; of the same name
(define chunk-numbers (make-free-identifier-mapping))
- (define (get-chunk-number id install?)
- (let ([n (add1 (free-identifier-mapping-get chunk-numbers id
- (lambda () 0)))])
- (when install?
- (free-identifier-mapping-put! chunk-numbers id n))
- n))
- (define (register-chunk-name name)
- (get-chunk-number name #t)))
+ (define (get-chunk-number id)
+ (free-identifier-mapping-get chunk-numbers id (lambda () #f)))
+ (define (inc-chunk-number id)
+ (free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id))))
+ (define (init-chunk-number id)
+ (free-identifier-mapping-put! chunk-numbers id 2)))
(define-syntax (chunk stx)
(syntax-case stx ()
[(_ name expr ...)
;; no need for more error checking, using chunk for the code will do that
(identifier? #'name)
- (let ([n (get-chunk-number (syntax-local-introduce #'name) #f)]
- [str (symbol->string (syntax-e #'name))])
+ (let* ([n (get-chunk-number (syntax-local-introduce #'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 ...)))
- (if (n . > . 1)
- (let ([str
- (format
- "need to handle secondary tags: ~a ~a\n"
- n
- str)])
- #`(begin
- (italic #,str)))
- (with-syntax ([tag str]
- [str str]
- [((for-label-mod ...) ...)
- (map (lambda (expr)
- (syntax-case expr (require)
- [(require mod ...)
- (let loop ([mods (syntax->list #'(mod ...))])
- (cond
- [(null? mods) null]
- [else
- (syntax-case (car mods) (for-syntax)
- [(for-syntax x ...)
- (loop (cdr mods))
- #;
- (append (loop (syntax->list #'(x ...)))
- (loop (cdr mods)))]
- [x
- (cons #'x (loop (cdr mods)))])]))]
- [else null]))
- (syntax->list #'(expr ...)))])
- #`(begin
- (require (for-label for-label-mod ... ...))
- (define-syntax name (make-element-id-transformer
- (lambda (stx) #'(chunkref name))))
- (begin-for-syntax (register-chunk-name #'name))
- (make-splice
- (list (make-toc-element
- #f
- (list (elemtag '(chunk tag)
- (bold (italic (scheme name)) " ::=")))
- (list (smaller (elemref '(chunk tag) #:underline? #f
- str))))
- (schemeblock expr ...)))))))]))
+ (with-syntax ([tag tag]
+ [str str]
+ [((for-label-mod ...) ...)
+ (map (lambda (expr)
+ (syntax-case expr (require)
+ [(require mod ...)
+ (let loop ([mods (syntax->list #'(mod ...))])
+ (cond
+ [(null? mods) null]
+ [else
+ (syntax-case (car mods) (for-syntax)
+ [(for-syntax x ...)
+ (append (loop (syntax->list #'(x ...)))
+ (loop (cdr mods)))]
+ [x
+ (cons #'x (loop (cdr mods)))])]))]
+ [else null]))
+ (syntax->list #'(expr ...)))]
+
+ [(rest ...) (if n
+ #`((subscript #,(format "~a" n)))
+ #`())])
+
+ #`(begin
+ (require (for-label for-label-mod ... ...))
+ #,@(if n
+ #'()
+ #'((define-syntax name (make-element-id-transformer
+ (lambda (stx) #'(chunkref name))))
+ (begin-for-syntax (init-chunk-number #'name))))
+ (make-splice
+ (list (make-toc-element
+ #f
+ (list (elemtag '(chunk tag)
+ (bold (italic (scheme name)) " ::=")))
+ (list (smaller (elemref '(chunk tag) #:underline? #f
+ str
+ rest ...))))
+ (schemeblock expr ...))))))]))
(define-syntax (chunkref stx)
(syntax-case stx ()
[(_ id)
(identifier? #'id)
- (with-syntax ([str (format "~a" (syntax-e #'id))])
- #'(elemref '(chunk str) #:underline? #f str))]))
+ (with-syntax ([tag (format "~a:1" (syntax-e #'id))]
+ [str (format "~a" (syntax-e #'id))])
+ #'(elemref '(chunk tag) #:underline? #f str))]))
(provide (all-from-out scheme/base
