blob: 1ba75eb447a1dcff4519d3d1d8b8cfd0cb3549df (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
(define (register-srfi-126!)
(define (hashtable-ref* table key fail success)
(define-values (value found?) (hashtable-lookup table key))
(if found?
(success value)
(fail)))
(define (hashtable-ref/default* table key default)
(hashtable-ref table key default))
(define (hashtable-set!* table . obj)
(let loop ((obj obj))
(if (null? obj)
table
(begin
(hashtable-set! table (car obj) (cadr obj))
(loop (cddr obj))))))
(define (hashtable-delete-all!* table keys)
(for-each
(lambda (key)
(hashtable-delete! table key))
keys)
table)
(define (hashtable-intern!* table key default)
(define val (hashtable-intern! table key default))
(values table val))
(define (hashtable-update/default!* table key updater default)
(hashtable-update! table key updater default)
table)
(define (hashtable-pop!* table)
(if (hashtable-empty? table)
(error "popped empty dictionary")
(call-with-values
(lambda () (hashtable-pop! table))
(lambda (key value) (values table key value)))))
(define (hashtable-update-all!* proc table)
(hashtable-update-all! table proc)
table)
(define (hashtable-filter!* proc table)
(hashtable-prune! table
(lambda (key value)
(not (proc key value))))
table)
(define (hashtable-remove!* proc table)
(hashtable-prune! table proc)
table)
(define (hashtable-search* table key fail success)
(define (handle-success value)
(define (update new-key new-value obj)
(unless (eq? new-key key)
(hashtable-delete! table key))
(hashtable-set! table new-key new-value)
(values table obj))
(define (remove obj)
(hashtable-delete! table key)
(values table obj))
(success key value update remove))
(define (handle-fail)
(define (ignore obj)
(values table obj))
(define (insert value obj)
(hashtable-set! table key value)
(values table obj))
(fail insert ignore))
(define default (cons #f #f))
(define found (hashtable-ref table key default))
(if (eq? default found)
(handle-fail)
(handle-success found)))
(define (hashtable-for-each* proc table)
(hashtable-walk table proc)
table)
(define (hashtable-map->lset* proc table)
(hashtable-map->lset table proc))
(define (hashtable-keys* table)
(vector->list (hashtable-keys table)))
(define (hashtable-values* table)
(vector->list (hashtable-values table)))
(define (hashtable-entries* table)
(call-with-values
(lambda () (hashtable-entries table))
(lambda (keys vals)
(values
(vector->list keys)
(vector->list vals)))))
(register-dictionary!
'dictionary? hashtable?
'dict-empty? hashtable-empty?
'dict-contains? hashtable-contains?
'dict-ref hashtable-ref*
'dict-ref/default hashtable-ref/default*
'dict-set! hashtable-set!*
'dict-delete-all! hashtable-delete-all!*
'dict-intern! hashtable-intern!*
'dict-update/default! hashtable-update/default!*
'dict-pop! hashtable-pop!*
'dict-map! hashtable-update-all!*
'dict-filter! hashtable-filter!*
'dict-remove! hashtable-remove!*
'dict-search! hashtable-search*
'dict-size hashtable-size
'dict-for-each hashtable-for-each*
'dict-keys hashtable-keys*
'dict-values hashtable-values*
'dict-entries hashtable-entries*
'dict-map->list hashtable-map->lset*))
|
