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