blob: 1c5ffe84f493d74e0aee35c3f88bdfa6bd6cd4aa (
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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
(define registry '())
(define (lookup dictionary fail-on-notfound?)
(let loop ((r registry))
(cond
((null? r) (if fail-on-notfound?
(error "Not a recognized dictionary" dictionary)
#f))
((dcall d? (car r) dictionary) (car r))
(else (loop (cdr r))))))
(define (make-internal-wrapper name proc)
(cond
((or (equal? name 'dict-set!)
(equal? name 'dict-adjoin!)
(equal? name 'dict-delete!))
(lambda (vec dict objs)
(apply proc (cons dict objs))))
(else
(lambda (vec . args)
(apply proc args)))))
(define (register-dictionary! . lst)
(define vec (vector-copy model-vec))
(do ((lst lst (cddr lst)))
((null? lst))
(when (null? (cdr lst))
(error "Uneven amount of arguments" lst))
(let ((proc-name (car lst))
(proc (cadr lst)))
(define index
(cond
((assoc proc-name dname-map) => cdr)
(else (error "Unrecognized procedure name" proc-name))))
(unless (procedure? proc)
(error "Not a procedure" proc))
(vector-set! vec index (make-internal-wrapper proc-name proc))))
(let loop ((reg registry))
(define new-reg (reverse (cons vec (reverse reg))))
(if (eq? reg registry)
(set! registry new-reg)
(loop registry))))
;;; External (exported) procedure definitions
(define-syntax dispatch
(syntax-rules ()
((dispatch index dictionary args ...)
(let ((vec (lookup dictionary #t))) ; error if not found
((vector-ref vec index) vec dictionary args ...)))))
(define-syntax proc-dispatch
(syntax-rules ()
((dispatch index dictionary args ...)
(let ((vec (lookup dictionary #t))) ; error if not found
((vector-ref vec index) vec args ...)))))
(define (dictionary? obj)
(if (lookup obj #f) #t #f)) ; #f if not found
(define (dict-empty? dictionary)
(dispatch dempty? dictionary))
(define (dict-contains? dictionary key)
(dispatch dcontains? dictionary key))
(define dict-ref
(case-lambda
((dictionary key)
(dict-ref dictionary key error values))
((dictionary key failure)
(dict-ref dictionary key failure values))
((dictionary key failure success)
(dict-ref* dictionary key failure success))))
(define (dict-ref* dictionary key failure success)
(dispatch dref dictionary key failure success))
(define (dict-ref/default dictionary key default)
(dispatch dref/default dictionary key default))
(define (dict-set! dictionary . objs)
(dispatch dset! dictionary objs))
(define (dict-adjoin! dictionary . objs)
(dispatch dadjoin! dictionary objs))
(define (dict-delete! dictionary . keys)
(dispatch ddelete! dictionary keys))
(define (dict-delete-all! dictionary keylist)
(dispatch ddelete-all! dictionary keylist))
(define (dict-replace! dictionary key value)
(dispatch dreplace! dictionary key value))
(define (dict-intern! dictionary key failure)
(dispatch dintern! dictionary key failure))
(define dict-update!
(case-lambda
((dictionary key updater)
(dict-update! dictionary key updater error values))
((dictionary key updater failure)
(dict-update! dictionary key updater failure values))
((dictionary key updater failure success)
(dispatch dupdate! dictionary key updater failure success))))
(define (dict-update/default! dictionary key updater default)
(dispatch dupdate/default! dictionary key updater default))
(define (dict-pop! dictionary)
(dispatch dpop! dictionary))
(define (dict-map! proc dictionary)
(proc-dispatch dmap! dictionary proc dictionary))
(define (dict-filter! pred dictionary)
(proc-dispatch dfilter! dictionary pred dictionary))
(define (dict-remove! pred dictionary)
(proc-dispatch dremove! dictionary pred dictionary))
(define (dict-search! dictionary key failure success)
(dispatch dsearch! dictionary key failure success))
(define (dict-size dictionary)
(dispatch dsize dictionary))
(define (dict-for-each proc dictionary)
(proc-dispatch dfor-each dictionary proc dictionary))
(define (dict-count pred dictionary)
(proc-dispatch dcount dictionary pred dictionary))
(define (dict-any pred dictionary)
(proc-dispatch dany dictionary pred dictionary))
(define (dict-every pred dictionary)
(proc-dispatch devery dictionary pred dictionary))
(define (dict-keys dictionary)
(dispatch dkeys dictionary))
(define (dict-values dictionary)
(dispatch dvalues dictionary))
(define (dict-entries dictionary)
(dispatch dentries dictionary))
(define (dict-fold proc knil dictionary)
(proc-dispatch dfold dictionary proc knil dictionary))
(define (dict-map->list proc dictionary)
(proc-dispatch dmap->list dictionary proc dictionary))
(define (dict->alist dictionary)
(dispatch d->alist dictionary))
|
