lp.rkt (3772B)
1 #lang scheme/base 2 3 (require (for-syntax scheme/base syntax/boundmap) 4 scribble/scheme scribble/decode scribble/manual scribble/struct) 5 6 (begin-for-syntax 7 ;; maps chunk identifiers to a counter, so we can distinguish multiple uses 8 ;; of the same name 9 (define chunk-numbers (make-free-identifier-mapping)) 10 (define (get-chunk-number id) 11 (free-identifier-mapping-get chunk-numbers id (lambda () #f))) 12 (define (inc-chunk-number id) 13 (free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id)))) 14 (define (init-chunk-number id) 15 (free-identifier-mapping-put! chunk-numbers id 2))) 16 17 (define-syntax-rule (define-chunk chunk-id racketblock) 18 (define-syntax (chunk-id stx) 19 (syntax-case stx () 20 [(_ name expr (... ...)) 21 ;; no need for more error checking, using chunk for the code will do that 22 (identifier? #'name) 23 (let* ([n (get-chunk-number (syntax-local-introduce #'name))] 24 [str (symbol->string (syntax-e #'name))] 25 [tag (format "~a:~a" str (or n 1))]) 26 27 (when n 28 (inc-chunk-number (syntax-local-introduce #'name))) 29 30 (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr (... ...)))) 31 32 (with-syntax ([tag tag] 33 [str str] 34 [((for-label-mod (... ...)) (... ...)) 35 (map (lambda (expr) 36 (syntax-case expr (require) 37 [(require mod (... ...)) 38 (let loop ([mods (syntax->list #'(mod (... ...)))]) 39 (cond 40 [(null? mods) null] 41 [else 42 (syntax-case (car mods) (for-syntax) 43 [(for-syntax x (... ...)) 44 (append (loop (syntax->list #'(x (... ...)))) 45 (loop (cdr mods)))] 46 [x 47 (cons #'x (loop (cdr mods)))])]))] 48 [else null])) 49 (syntax->list #'(expr (... ...))))] 50 51 [(rest (... ...)) (if n 52 #`((subscript #,(format "~a" n))) 53 #`())]) 54 #`(begin 55 (require (for-label for-label-mod (... ...) (... ...))) 56 #,@(if n 57 #'() 58 #'((define-syntax name (make-element-id-transformer 59 (lambda (stx) #'(chunkref name)))) 60 (begin-for-syntax (init-chunk-number #'name)))) 61 (make-splice 62 (list (make-toc-element 63 #f 64 (list (elemtag '(chunk tag) 65 (bold (italic (racket name)) " ::="))) 66 (list (smaller (elemref '(chunk tag) #:underline? #f 67 str 68 rest (... ...))))) 69 (racketblock expr (... ...)))))))]))) 70 71 (define-chunk chunk racketblock) 72 (define-chunk CHUNK RACKETBLOCK) 73 74 (define-syntax (chunkref stx) 75 (syntax-case stx () 76 [(_ id) 77 (identifier? #'id) 78 (with-syntax ([tag (format "~a:1" (syntax-e #'id))] 79 [str (format "~a" (syntax-e #'id))]) 80 #'(elemref '(chunk tag) #:underline? #f str))])) 81 82 83 (provide (all-from-out scheme/base 84 scribble/manual) 85 chunk CHUNK)