source: project/release/4/lookup-table/tags/1.9.1/lookup-table.scm @ 15713

Last change on this file since 15713 was 15713, checked in by Kon Lovett, 10 years ago

Bug fix for duplicated C procedures by compiler.

File size: 12.9 KB
Line 
1;;;; lookup-table.scm
2;;;; Kon Lovett, Apr '09
3
4(declare
5  (usual-integrations)
6  (disable-interrupts)
7  (fixnum)
8  (inline)
9  (inline-limit 50)
10  (local)
11  (no-procedure-checks) )
12
13(include "chicken-primitive-object-inlines")
14(include "chicken-primitive-alist")
15
16;;;
17
18(module lookup-table (;export
19  dict-safe-mode
20  make-dict
21  alist->dict
22  dict->alist
23  dict?
24  dict-equivalence-function
25  dict-count
26  dict-keys
27  dict-values
28  dict-ref
29  dict-set!
30  dict-exists?
31  dict-update!
32  dict-update-list!
33  dict-update-dict!
34  dict-delete!
35  dict-for-each
36  dict-search
37  dict-merge!
38  dict-print )
39
40  (import
41    scheme chicken
42    srfi-1 srfi-69 ports data-structures extras
43    miscmacros type-checks type-errors srfi-9-ext)
44  (require-library srfi-1 srfi-69 extras miscmacros type-checks type-errors srfi-9-ext)
45
46;;;
47
48;;; Variant Dictionary
49
50(define-record-type/primitive dict
51        (make-dictbase data)
52        dict?
53        (data dict-data-ref dict-data-set!)
54        (test dict-test-ref dict-test-set!)
55        (to-alist dict->alist-ref dict->alist-set!)
56        (ref dict-ref-ref dict-ref-set!)
57        (set dict-set-ref dict-set-set!)
58        (delete dict-delete-ref dict-delete-set!)
59        (for-each dict-for-each-ref dict-for-each-set!)
60        (merge dict-merge-ref dict-merge-set!)
61        (search dict-search-ref dict-search-set!)
62        (count dict-count-ref dict-count-set!)
63        (keys dict-keys-ref dict-keys-set!)
64        (values dict-values-ref dict-values-set!)
65        (exists dict-exists-ref dict-exists-set!) )
66
67(define (set-dict-procs! dict tst to ref set del for mrg sch cnt keys vals exsts)
68        (dict-test-set! dict tst)
69        (dict->alist-set! dict to)
70        (dict-ref-set! dict ref)
71        (dict-set-set! dict set)
72        (dict-delete-set! dict del)
73        (dict-for-each-set! dict for)
74        (dict-merge-set! dict mrg)
75        (dict-search-set! dict sch)
76        (dict-count-set! dict cnt)
77        (dict-keys-set! dict keys)
78        (dict-values-set! dict vals)
79        (dict-exists-set! dict exsts)
80        dict )
81
82; Representation independent primitive calls
83
84(define (dictbase-test dict) ((dict-test-ref dict) (dict-data-ref dict)))
85(define (dictbase->alist dict) ((dict->alist-ref dict) (dict-data-ref dict)))
86(define (dictbase-ref dict key def) ((dict-ref-ref dict) (dict-data-ref dict) key def))
87(define (dictbase-set! dict key val) ((dict-set-ref dict) (dict-data-ref dict) key val))
88(define (dictbase-delete! dict key) ((dict-delete-ref dict) (dict-data-ref dict) key))
89(define (dictbase-for-each dict proc) ((dict-for-each-ref dict) (dict-data-ref dict) proc))
90(define (dictbase-merge! dict1 dict2) ((dict-merge-ref dict1) (dict-data-ref dict1) (dict-data-ref dict2)))
91(define (dictbase-search dict proc def) ((dict-search-ref dict) (dict-data-ref dict) proc def))
92(define (dictbase-count dict) ((dict-count-ref dict) (dict-data-ref dict)))
93(define (dictbase-keys dict) ((dict-keys-ref dict) (dict-data-ref dict)))
94(define (dictbase-values dict) ((dict-values-ref dict) (dict-data-ref dict)))
95(define (dictbase-exists? dict key) ((dict-exists-ref dict) (dict-data-ref dict) key))
96
97;; Association List
98
99(define (make-alist-data test al) (%cons test al))
100(define (alist-dict-test data) (%car data))
101(define (alist-dict-alist data) (%cdr data))
102(define (alist-dict-alist-set! data al) (%set-cdr! data al))
103
104(define (set-alist-dict-procs! dict)
105        (set-dict-procs! dict
106                alist-dict-test-ref
107                alist-dict->alist
108                alist-dict-ref
109                alist-dict-set!
110                alist-dict-delete!
111                alist-dict-for-each
112                alist-dict-merge!
113                alist-dict-search
114                alist-dict-count
115                alist-dict-keys
116                alist-dict-values
117                alist-dict-exists?) )
118
119;; Hash Table
120
121(define (make-htable-data test ht) (%cons test ht))
122(define (htable-dict-test data) (%car data))
123(define (htable-dict-htable data) (%cdr data))
124(define (htable-dict-htable-set! data ht) (%set-cdr!/mutate data ht))
125
126(define (set-htable-dict-procs! dict)
127        (set-dict-procs! dict
128                htable-dict-test-ref
129                htable-dict->alist
130                htable-dict-ref
131                htable-dict-set!
132                htable-dict-delete!
133                htable-dict-for-each
134                htable-dict-merge!
135                htable-dict-search
136                htable-dict-count
137                htable-dict-keys
138                htable-dict-values
139                htable-dict-exists?) )
140
141;;;
142
143;; Argument validation & literal object return.
144
145(define *dict-safe-mode* #f)
146
147;;; Alist Dictionary
148
149(define (alist-dict-test-ref data) (alist-dict-test data))
150
151(define (alist-dict->alist data)
152  (let ((dat (alist-dict-alist data)))
153    (if *dict-safe-mode* (list-copy dat)
154        dat ) ) )
155
156(define (alist-dict-ref data key def)
157        (%alist-ref key (alist-dict-alist data) (alist-dict-test data) def) )
158
159(define (alist-dict-set! data key obj)
160        (alist-dict-alist-set!
161          data
162    (%alist-update! key obj (alist-dict-alist data) (alist-dict-test data))) )
163
164(define (alist-dict-delete! data key)
165        (alist-dict-alist-set!
166          data
167    (%alist-delete! key (alist-dict-alist data) (alist-dict-test data))) )
168
169(define (alist-dict-for-each data proc)
170        (%list-for-each/1
171          (lambda (cell) (proc (%car cell) (%cdr cell)))
172    (alist-dict-alist data)) )
173
174(define (alist-dict-merge! data1 data2)
175        (let ((test (alist-dict-test data1))
176              (al (alist-dict-alist data1)))
177                (%list-for-each/1
178                  (lambda (cell) (set! al (%alist-update! (%car cell) (%cdr cell) al test)))
179      (alist-dict-alist data2))
180                (alist-dict-alist-set! data1 al) ) )
181
182(define (alist-dict-search data proc def) (%alist-find proc (alist-dict-alist data) def))
183
184(define (alist-dict-count data) (%list-length (alist-dict-alist data)))
185
186(define (alist-dict-keys data) (%list-map/1 (lambda (x) (%car x)) (alist-dict-alist data)))
187
188(define (alist-dict-values data) (%list-map/1 (lambda (x) (%cdr x)) (alist-dict-alist data)))
189
190(define (alist-dict-exists? data key)
191  (not (%undefined-value? (alist-dict-ref data key (%undefined-value)))) )
192
193(define (make-alist-dict test al)
194  (set-alist-dict-procs! (make-dictbase (make-alist-data test al))) )
195
196(define (alist-dict? dict) (%eq? alist-dict-test-ref (dictbase-test dict)))
197
198(define (become-alist-dict! dict)
199        (dict-data-set! dict (make-alist-data (dictbase-test dict) (dictbase->alist dict)))
200        (set-alist-dict-procs! dict) )
201
202;;; Hash-table Dictionary
203
204(define (htable-dict-test-ref data) (htable-dict-test data))
205
206(define (htable-dict->alist data) (hash-table->alist (htable-dict-htable data)))
207
208(define (htable-dict-ref data key def)
209        (hash-table-ref/default (htable-dict-htable data) key def) )
210
211(define (htable-dict-set! data key obj)
212        (hash-table-set! (htable-dict-htable data) key obj) )
213
214(define (htable-dict-delete! data key)
215        (hash-table-delete! (htable-dict-htable data) key) )
216
217(define (htable-dict-for-each data proc)
218        (hash-table-for-each (htable-dict-htable data) proc) )
219
220(define (htable-dict-merge! data1 data2)
221        (htable-dict-htable-set!
222          data1
223          (hash-table-merge! (htable-dict-htable data1) (htable-dict-htable data2))) )
224
225(define (htable-dict-search data proc def)
226        (let ((ht (htable-dict-htable data))
227                                (ret #f))
228                (let ((res (let/cc return
229                 (hash-table-walk ht
230                   (lambda (key val) (when (proc key val) (set! ret #t) (return val)))))))
231                        (if ret res def) ) ) )
232
233(define (htable-dict-count data) (hash-table-size (htable-dict-htable data)))
234
235(define (htable-dict-keys data) (hash-table-keys (htable-dict-htable data)))
236
237(define (htable-dict-values data) (hash-table-values (htable-dict-htable data)))
238
239(define (htable-dict-exists? data key) (hash-table-exists? (htable-dict-htable data) key))
240
241(define (make-htable-dict test ht)
242  (set-htable-dict-procs! (make-dictbase (make-htable-data test ht))) )
243
244(define (htable-dict? dict) (%eq? htable-dict-test-ref (dictbase-test dict)))
245
246(define (become-htable-dict! dict)
247        (let ((test (dictbase-test dict)))
248                (dict-data-set! dict (make-htable-data test (alist->hash-table (dictbase->alist dict) test))))
249        (set-htable-dict-procs! dict) )
250
251;; Argument Checks
252
253(define-check-type dict)
254
255(define (check-value loc obj #!optional nam)
256  (when (%undefined-value? obj)
257    (error-argument-type loc obj "non-undefined value" nam)) )
258
259(define (check-alist loc obj #!optional nam)
260  (check-list loc obj nam)
261  (let loop ((al obj) (tal '()))
262    (cond ((%null? al) )
263          ((not (%pair? (%car al)))
264            (error-argument-type loc obj "association list" nam) )
265          ((%memq (%cdr al) tal)
266            (error-argument-type loc obj "proper list" nam) )
267          (else
268            (loop (%cdr al) (%cons (%cdr al) tal)) ) ) ) )
269
270;; Errors
271
272(define-error-type dict)
273
274;; Print worker
275
276(define (*dict-print dict)
277  (define (print-node-table dict spcr)
278    (dictbase-for-each dict
279      (lambda (key val)
280        (%list-for-each/1 display spcr)
281        (cond ((dict? val)
282                (write key) (display " :") (newline)
283                (print-node-table val (%cons "  " spcr)) )
284              (else
285                (write key) (display " : ") (pretty-print val)) ) ) ) )
286    (print-node-table dict '()) )
287
288;; Update workers
289
290(define (*dict-update! dict key valu-func updt-func curr loc)
291  (let ((val (updt-func
292               (if (not (%undefined-value? curr)) curr
293                   (let ((val (valu-func)))
294                     (when *dict-safe-mode* (check-value loc val))
295                     val ) ) ) ) )
296    (dictbase-set! dict key val)
297    val ) )
298
299(define (+dict-update! dict key valu-func updt-func loc)
300  (when *dict-safe-mode*
301    (check-dict loc dict)
302    (check-procedure loc valu-func)
303    (check-procedure loc updt-func) )
304  (let* ((curr (dictbase-ref dict key (%undefined-value)))
305         (updt (*dict-update! dict key valu-func updt-func curr loc)))
306    (unless (%undefined-value? curr) (dict-bestfit dict))
307    updt ) )
308
309;; Dictionary Type
310
311(define (dict-same-kind? dict1 dict2) (%eq? (dict-test-ref dict1) (dict-test-ref dict2)))
312(define (dict-same-test? dict1 dict2) (%eq? (dictbase-test dict1) (dictbase-test dict2)))
313
314(define (dict-bestfit dict)
315        (if (%fx< MAGIC-LIMIT (dictbase-count dict))
316      (unless (htable-dict? dict) (become-htable-dict! dict))
317      (unless (alist-dict? dict) (become-alist-dict! dict)) ) )
318
319;;; Globals
320
321(define-parameter dict-safe-mode *dict-safe-mode*
322  (lambda (x)
323    (set! *dict-safe-mode* x)
324    x))
325
326(define (make-dict #!optional (test eq?) (size 0))
327  (when *dict-safe-mode*
328    (check-cardinal-fixnum 'make-dict size "size")
329    (check-procedure 'make-dict test) )
330        (if (%fx< MAGIC-LIMIT size)
331      (make-htable-dict test (make-hash-table test))
332      (make-alist-dict test '())) )
333
334(define (alist->dict al #!optional (test eq?) (size 0))
335  (when *dict-safe-mode*
336    (check-alist 'alist->dict al "alist")
337    (check-cardinal-fixnum 'alist->dict size "size")
338    (check-procedure 'alist->dict test) )
339        (if (or (%fx< MAGIC-LIMIT size) (%fx< MAGIC-LIMIT (%list-length al)))
340      (make-htable-dict test (alist->hash-table al test))
341      (make-alist-dict test al)) )
342
343(define (dict->alist dict)
344  (when *dict-safe-mode* (check-dict 'dict->alist dict))
345        (dictbase->alist dict) )
346
347(define (dict-equivalence-function dict)
348  (when *dict-safe-mode* (check-dict 'dict-equivalence-function dict))
349        (dictbase-test dict) )
350
351(define (dict-count dict)
352  (when *dict-safe-mode* (check-dict 'dict-count dict))
353        (dictbase-count dict) )
354
355(define (dict-keys dict)
356  (when *dict-safe-mode* (check-dict 'dict-keys dict))
357        (dictbase-keys dict) )
358
359(define (dict-values dict)
360  (when *dict-safe-mode* (check-dict 'dict-values dict))
361        (dictbase-values dict) )
362
363(define (dict-ref dict key #!optional def)
364  (when *dict-safe-mode* (check-dict 'dict-ref dict))
365        (dictbase-ref dict key def) )
366
367(define (dict-set! dict key obj)
368  (when *dict-safe-mode*
369    (check-value 'dict-set! obj)
370    (check-dict 'dict-set! dict) )
371        (dictbase-set! dict key obj)
372        (dict-bestfit dict) )
373
374(define (dict-exists? dict key)
375  (when *dict-safe-mode* (check-dict 'dict-exists? dict))
376  (dictbase-exists? dict key) )
377
378(define (dict-update! dict key valu-func #!optional (updt-func identity))
379        (+dict-update! dict key valu-func updt-func 'dict-update!) )
380
381(define (dict-update-list! dict key . vals)
382  (+dict-update! dict key (lambda () '()) (cut fold cons <> (reverse! vals)) 'dict-update-list!) )
383
384(define (dict-update-dict! dict key)
385  (+dict-update! dict key (cut make-dict) identity 'dict-update-dict!) )
386
387(define (dict-delete! dict key)
388  (when *dict-safe-mode* (check-dict 'dict-delete! dict))
389        (dictbase-delete! dict key)
390        (dict-bestfit dict) )
391
392(define (dict-for-each dict proc)
393  (when *dict-safe-mode*
394    (check-dict 'dict-for-each dict)
395    (check-procedure 'dict-for-each proc) )
396        (dictbase-for-each dict proc) )
397
398(define (dict-search dict proc #!optional def)
399  (when *dict-safe-mode*
400    (check-dict 'dict-search dict)
401    (check-procedure 'dict-search proc) )
402        (dictbase-search dict proc def) )
403
404(define (dict-merge! dict . dicts)
405  (when *dict-safe-mode* (check-dict 'dict-merge! dict))
406        (%list-for-each/1
407                (lambda (dictx)
408      (when *dict-safe-mode*
409        (check-dict 'dict-merge! dictx)
410        (unless (dict-same-test? dict dictx)
411          (error "cannot merge lookup-tables; incompatible test") ) )
412                        (if (dict-same-kind? dict dictx) (dictbase-merge! dict dictx)
413          (dictbase-for-each dictx (cut dict-set! dict <> <>)) ) )
414                dicts)
415        (dict-bestfit dict) )
416
417(define (dict-print dict #!optional port)
418  (if (not port) (*dict-print dict)
419      (with-output-to-port port (lambda () (*dict-print dict)) ) ) )
420
421) ;module lookup-table
Note: See TracBrowser for help on using the repository browser.