1 2(module boundmap racket/base 3 (require (for-syntax racket/base)) 4 5 (define-syntax (make-mapping-code stx) 6 (syntax-case stx () 7 [(_ identifier->symbol 8 make-identifier-mapping 9 identifier-mapping-ht 10 identifier-mapping? 11 identifier-mapping-get 12 identifier-mapping-put! 13 identifier-mapping-for-each 14 identifier-mapping-map 15 identifier=?) 16 (and (identifier? (syntax identifier-mapping)) 17 (identifier? (syntax identifier-mapping-get)) 18 (identifier? (syntax identifier-mapping-put!)) 19 (identifier? (syntax identifier-mapping-for-each)) 20 (identifier? (syntax identifier-mapping-map))) 21 (syntax 22 (begin 23 24 (define mk-identifier-mapping 25 (let ([make-identifier-mapping 26 (lambda () 27 (make-identifier-mapping 28 (make-hasheq)))]) 29 make-identifier-mapping)) 30 31 (define identifier-mapping-get 32 (lambda (bi id [fail (lambda () 33 (error 'identifier-mapping-get 34 "no mapping for ~e" 35 id))]) 36 (let ([i (ormap (lambda (i) 37 (and (identifier=? (car i) id) 38 i)) 39 (hash-ref (identifier-mapping-ht bi) 40 (identifier->symbol id) 41 null))]) 42 (if i 43 (cdr i) 44 (fail))))) 45 46 (define identifier-mapping-put! 47 (lambda (bi id v) 48 (let ([l (hash-ref 49 (identifier-mapping-ht bi) 50 (identifier->symbol id) 51 null)]) 52 (hash-set! 53 (identifier-mapping-ht bi) 54 (identifier->symbol id) 55 (let loop ([l l]) 56 (cond 57 [(null? l) (list (cons id v))] 58 [(identifier=? (caar l) id) 59 (cons (cons id v) (cdr l))] 60 [else (cons (car l) (loop (cdr l)))])))))) 61 62 (define identifier-mapping-for-each 63 (lambda (bi f) 64 (hash-for-each (identifier-mapping-ht bi) 65 (lambda (k v) 66 (for-each (lambda (i) 67 (f (car i) (cdr i))) 68 v))))) 69 70 (define identifier-mapping-map 71 (lambda (bi f) 72 (let* ([r null]) 73 (identifier-mapping-for-each 74 bi 75 (lambda (k v) 76 (set! r (cons (f k v) r)))) 77 (reverse r)))) 78 79 (provide (rename-out [mk-identifier-mapping make-identifier-mapping])) 80 (provide identifier-mapping? 81 identifier-mapping-get 82 identifier-mapping-put! 83 identifier-mapping-for-each 84 identifier-mapping-map)))])) 85 86 ;; ht : hash-table[symbol(key) -> (listof (cons syntax[identifier] any))] 87 ;; the entries in the hash-table narrow the mapping to 88 ;; the identifiers that match that key. 89 (define-struct bound-identifier-mapping (ht)) 90 91 (define (bound-identifier->symbol id) (syntax-e id)) 92 93 (make-mapping-code 94 bound-identifier->symbol 95 make-bound-identifier-mapping 96 bound-identifier-mapping-ht 97 bound-identifier-mapping? 98 bound-identifier-mapping-get 99 bound-identifier-mapping-put! 100 bound-identifier-mapping-for-each 101 bound-identifier-mapping-map 102 bound-identifier=?) 103 104 ;; ht : hash-table[symbol(key) -> (listof (cons syntax[identifier] any))] 105 ;; the entries in the hash-table narrow the mapping to 106 ;; the identifiers that match that key. 107 (define-struct module-identifier-mapping (ht)) 108 109 (define (module-identifier->symbol id) 110 (identifier-binding-symbol id)) 111 112 (make-mapping-code 113 module-identifier->symbol 114 make-module-identifier-mapping 115 module-identifier-mapping-ht 116 module-identifier-mapping? 117 module-identifier-mapping-get 118 module-identifier-mapping-put! 119 module-identifier-mapping-for-each 120 module-identifier-mapping-map 121 free-identifier=?)) 122