Commit | Line | Data |
---|---|---|
57778d30 C |
1 | (setq rcs-hash- |
2 | "$Header: hash.l,v 1.2 85/03/24 11:36:16 sklower Exp $") | |
3 | ||
4 | ; Aug 5, 1982 | |
5 | ; (c) copyright 1982, Massachusetts Institute of Technology | |
6 | ; | |
7 | ; Hash tables are basically just fast property lists. There are much the | |
8 | ; same access functions: puthash, gethash, and remhash. The syntax is | |
9 | ; different though. For small lists property lists are probably what you | |
10 | ; want but when the lists start to become large hash tables become | |
11 | ; infinitely better than property lists. | |
12 | ||
13 | ;; Current bugs: hash-table-rehash and the equal version need to be | |
14 | ;; rewritten. There is no reason to write the array twice. | |
15 | ||
16 | ; Note very carefully that the syntax is <puthash key value hash-table>, | |
17 | ; <gethash key hash-table>, and <remhash key hash-table>. | |
18 | ||
19 | ; Before hash tables are used they have to be made i.e. you first do | |
20 | ; (setq myhash (make-hash-table)) then (puthash 'name 'joe myhash). | |
21 | ; Make-hash-table takes several alternating keywords and arguments | |
22 | ; the only one of which you will probably use is :size. So | |
23 | ; (setq otherhash (make-hash-table ':size 20)) will make otherhash a | |
24 | ; hash table of length 20. If you know what the length of the hash table | |
25 | ; will be and it is greater than about 20 it is a good idea to specify | |
26 | ; the length so that hash-table-rehash will not need to be called. | |
27 | ; This will speed up puthashing considerably especially when the hash | |
28 | ; table is very large. | |
29 | ; Keys must be eq, equal will not work. | |
30 | ||
31 | #+Franz (environment-maclisp) | |
32 | ||
33 | (defstruct (hash-table (:constructor make-hash-table-internal) | |
34 | :named) | |
35 | (real-hash-table (new-vector 17)) ;where entries are stored | |
36 | (hash-table-fullness 0) ; how many entries in table | |
37 | (rehash-after-n-misses 4) ; when puthashing you rehash the table | |
38 | ; if you miss this many times | |
39 | (hash-table-size 17) ; how big the vector is | |
40 | (hash-table-rehash-size 1.5) ; factor to multiply by current size | |
41 | ; to the get new size of the vector | |
42 | (hash-table-rehash-function 'hash-table-rehash)) | |
43 | ||
44 | ; Make-hash-table makes a hash table. The vector that all the information | |
45 | ; is stored in is made nmiss larger than the apparent size of the hash | |
46 | ; table so that if you hash to a number close to the size of the table | |
47 | ; you do not miss right off the table. So that for example if you | |
48 | ; hash to the last element of the table and miss you are not aff the table. | |
49 | ||
50 | (defun make-hash-table (&rest options &aux (size 8) (rhf 'hash-table-rehash) | |
51 | (rhs 1.5) (nmisses 4)) | |
52 | (loop for (key option) on options by #'cddr | |
53 | do (selectq key | |
54 | (:size (setq size option)) | |
55 | (:rehash-function (setq rhf option)) | |
56 | (:rehash-size (setq rhs option)) | |
57 | (otherwise | |
58 | (ferror () "~S is not a valid hash table option" | |
59 | key)))) | |
60 | (setq size (hash-table-good-size (* size 2))) | |
61 | (make-hash-table-internal | |
62 | real-hash-table (new-vector (+ size nmisses)) | |
63 | hash-table-size size | |
64 | rehash-after-n-misses nmisses | |
65 | hash-table-rehash-size rhs | |
66 | hash-table-rehash-function rhf)) | |
67 | ||
68 | (defun hash-table-good-size (size) | |
69 | (setq size (max (fix size) 17)) ;minimum size is 17 | |
70 | (or (oddp size) (setq size (1+ size))) ; make it odd | |
71 | (do () | |
72 | ((and (not (zerop (\ size 3))) ; make it a semi-prime number | |
73 | (not (zerop (\ size 5))) | |
74 | (not (zerop (\ size 7)))) | |
75 | size) | |
76 | (setq size (+ size 2)))) | |
77 | ||
78 | ;; Using conses instead of putting increasing the size of the data table | |
79 | ;; by a factor of two, decreases the amount of storage required for a | |
80 | ;; partially full hash table but can adversely affect the paging and | |
81 | ;; caching behavior of the hash table. Sometime, should meter this | |
82 | ;; difference. (A compactifying garbage collector could help.) | |
83 | ||
84 | (defmacro make-hash-element (key value) ; creates a hash element | |
85 | `(cons ,key ,value)) | |
86 | ||
87 | (defmacro hash-key (element) ; the key given a hash element | |
88 | `(car ,element)) | |
89 | ||
90 | (defmacro hash-value (element) ; the value of a hash element | |
91 | `(cdr ,element)) | |
92 | ||
93 | (defmacro si:hash-code (hash-table key) ;hash code for key | |
94 | `(\ (maknum ,key) (hash-table-size ,hash-table))) | |
95 | ||
96 | ; Gethash either returns the value associated with that key in that | |
97 | ; hash table or nil if there is none. | |
98 | ||
99 | (defun gethash (key hash-table &aux position-value) | |
100 | (do ((try-position (si:hash-code hash-table key) (1+ try-position)) | |
101 | (n (rehash-after-n-misses hash-table) (1- n)) | |
102 | (real-hash-table (real-hash-table hash-table))) | |
103 | ((zerop n) nil) ;it is not there so just return nil | |
104 | (cond ((eq key | |
105 | (hash-key (setq position-value | |
106 | (vref real-hash-table try-position)))) | |
107 | (return (hash-value position-value)))))) | |
108 | ||
109 | (eval-when (compile load eval) | |
110 | (defsetf gethash (e v) `(puthash ,(cadr e) ,v ,(caddr e)))) | |
111 | ||
112 | ; Puthash inserts a hash-element for the given key and value in the | |
113 | ; hash table that is passed to it. If the key already exists in the hash | |
114 | ; table the value of that key is replaced by the new value. If it finds an | |
115 | ; empty space it adds a hash-element for that key and value into that | |
116 | ; space and increments hash-table-fullness by one. If it cannot find | |
117 | ; the key or an empty space in four tries then it calls rehash on the | |
118 | ; hash table and tries again. | |
119 | ||
120 | (declare (localf puthash-internal)) | |
121 | ||
122 | (defun puthash (key value hash-table) | |
123 | (puthash-internal key value hash-table nil)) | |
124 | ||
125 | (defun swaphash (key value hash-table) | |
126 | (puthash-internal key value hash-table t)) | |
127 | ||
128 | (defun puthash-internal (key value hash-table swap?) | |
129 | (do ((try-position (si:hash-code hash-table key) (1+ try-position)) | |
130 | (n (rehash-after-n-misses hash-table) (1- n)) | |
131 | (real-hash-table (real-hash-table hash-table))) | |
132 | ((zerop n) ;if cannot find a place in n tries then rehash | |
133 | (funcall (hash-table-rehash-function hash-table) | |
134 | hash-table (hash-table-rehash-size hash-table)) | |
135 | (puthash key value hash-table)) | |
136 | (cond ((or (eq (hash-key (vref real-hash-table try-position)) | |
137 | key) | |
138 | (and (null (vref real-hash-table try-position)) | |
139 | (setf (hash-table-fullness hash-table) | |
140 | (1+ (hash-table-fullness hash-table))))) | |
141 | (return | |
142 | (prog1 (if swap? (hash-value (vref real-hash-table try-position)) | |
143 | value) | |
144 | (setf (vref real-hash-table try-position) | |
145 | (make-hash-element key value)))))))) | |
146 | ||
147 | ; Remhash removes the hash-element associated with the given key from | |
148 | ; the hash table that is passed to it. If it finds the element and removes | |
149 | ; it then it returns the key. If it cannot find the element then it returns | |
150 | ; nil. | |
151 | ||
152 | (defun remhash (key hash-table) | |
153 | (do ((try-position (si:hash-code hash-table key) (1+ try-position)) | |
154 | (n (rehash-after-n-misses hash-table) (1- n)) | |
155 | (real-hash-table (real-hash-table hash-table))) | |
156 | ((zerop n) nil) ;not in the hash table return nil | |
157 | (cond ((eq (hash-key (vref real-hash-table try-position)) key) | |
158 | (setf (vref real-hash-table try-position) nil) | |
159 | (return key))))) ;return the key if found and removed | |
160 | ||
161 | ; Hash-table-rehash first saves the contents of the current hash table | |
162 | ; in a temporary vector then puthashes the elements of this temporary vector | |
163 | ; into the original hash-table after making it larger by a factor of | |
164 | ; the variable grow. | |
165 | ||
166 | (defun hash-table-rehash (hash-table grow) | |
167 | (let* ((real-hash-table (real-hash-table hash-table)) | |
168 | (nmisses (rehash-after-n-misses hash-table)) | |
169 | (new-size (+ nmisses | |
170 | (hash-table-good-size (times grow | |
171 | (hash-table-size hash-table))))) | |
172 | (j 0) | |
173 | (temp-array (new-vector new-size))) | |
174 | (do ((current-position 0 (1+ current-position)) | |
175 | (old-size (+ (hash-table-size hash-table) nmisses))) | |
176 | ((>= current-position old-size)) | |
177 | (let ((current-hash-element (vref real-hash-table current-position))) | |
178 | (cond ((null current-hash-element)) | |
179 | (t (setf (vref temp-array j) current-hash-element) | |
180 | (setq j (1+ j)))))) | |
181 | (cond ((not (= grow 1)) ;if the hash table has grown | |
182 | (setf (real-hash-table hash-table) (new-vector new-size)) | |
183 | (setf (hash-table-fullness hash-table) 0) | |
184 | (setf (hash-table-size hash-table) (- new-size nmisses)))) | |
185 | (do ((position 0 (1+ position))) ;add old values to new table | |
186 | ((= position j)) | |
187 | (puthash (hash-key (vref temp-array position)) | |
188 | (hash-value (vref temp-array position)) | |
189 | hash-table)))) | |
190 | ||
191 | (defun si:lookhash (hash-table) | |
192 | (let ((real-hash-table (real-hash-table hash-table))) | |
193 | (loop for num from 0 to (1- (vsize real-hash-table)) | |
194 | collect (vref real-hash-table num)))) | |
195 | ||
196 | (defun maphash (func hash-table) | |
197 | (let ((real-hash-table (real-hash-table hash-table))) | |
198 | (loop for num from 0 to (1- (vsize real-hash-table)) | |
199 | with keyword and value | |
200 | do (setq keyword (vref real-hash-table num)) | |
201 | unless (null keyword) | |
202 | do (progn (setq value (cdr keyword) | |
203 | keyword (car keyword)) | |
204 | (funcall func keyword value))))) | |
205 | \f | |
206 | ;; SXHASH | |
207 | ;; Sigh, this also comes from the LISP machine | |
208 | ||
209 | (defun sxhash (x) | |
210 | (cond ((symbolp x) | |
211 | (sxhash-string (get_pname x))) | |
212 | ((stringp x) | |
213 | (sxhash-string x)) | |
214 | ((eq (typep x) 'fixnum) | |
215 | (if (minusp x) | |
216 | (logxor x #o-1777777777) | |
217 | x)) | |
218 | ((dtpr x) | |
219 | (do ((rot 4) | |
220 | (hash 0) | |
221 | (y)) | |
222 | ((atom x) | |
223 | (if (not (null x)) | |
224 | (setq hash (logxor (rot (sxhash x) (- rot 4)) hash))) | |
225 | (if (minusp hash) | |
226 | (logxor hash #o-1777777777) | |
227 | hash)) | |
228 | (setq y (pop x)) | |
229 | (if (>= (setq rot (+ rot 7)) 24) | |
230 | (setq rot (- rot 24))) | |
231 | (setq hash (logxor (rot (cond ((symbolp y) | |
232 | (sxhash-string (get_pname y))) | |
233 | ((stringp y) | |
234 | (sxhash-string y)) | |
235 | ((eq (typep y) 'fixnum) | |
236 | y) | |
237 | (t (sxhash y))) | |
238 | rot) | |
239 | hash)))) | |
240 | ((bigp x) | |
241 | (sxhash (bignum-to-list x))) | |
242 | ((floatp x) | |
243 | (fix x)) | |
244 | (t 0))) | |
245 | ||
246 | (defun sxhash-string (string) | |
247 | (do ((i 1 (1+ i)) | |
248 | (n (flatc string)) | |
249 | (hash 0)) | |
250 | ((> i n) | |
251 | (if (minusp hash) | |
252 | (logxor hash #o-1777777777) | |
253 | hash)) | |
254 | (setq hash (rot (logxor (getcharn string i) #o177) 7)))) | |
255 | \f | |
256 | ;; Equal hash tables | |
257 | ||
258 | ;; Notice the slots are exactly the same as in hash-table so we use the same | |
259 | ;; macros. | |
260 | ||
261 | (defstruct (equal-hash-table (:constructor make-equal-hash-table-internal) | |
262 | :named) | |
263 | (real-hash-table (new-vector 17)) ;where entries are stored | |
264 | (hash-table-fullness 0) ; how many entries in table | |
265 | (rehash-after-n-misses 4) ; when puthashing you rehash the table | |
266 | ; if you miss this many times | |
267 | (hash-table-size 17) ; how big the vector is | |
268 | (hash-table-rehash-size 1.5) ; factor to multiply by current size | |
269 | ; to the get new size of the vector | |
270 | (hash-table-rehash-function 'equal-hash-table-rehash)) | |
271 | ||
272 | ; Make-hash-table makes a hash table. The vector that all the information | |
273 | ; is stored in is made nmiss larger than the apparent size of the hash | |
274 | ; table so that if you hash to a number close to the size of the table | |
275 | ; you do not miss right off the table. So that for example if you | |
276 | ; hash to the last element of the table and miss you are not aff the table. | |
277 | ||
278 | (defun make-equal-hash-table (&rest options &aux (size 8) | |
279 | (rhf 'hash-table-rehash) | |
280 | (rhs 1.5) (nmisses 4)) | |
281 | (loop for (key option) on options by #'cddr | |
282 | do (selectq key | |
283 | (:size (setq size option)) | |
284 | (:rehash-function (setq rhf option)) | |
285 | (:rehash-size (setq rhs option)) | |
286 | (otherwise | |
287 | (ferror () "~S is not a valid hash table option" | |
288 | key)))) | |
289 | (setq size (hash-table-good-size (* size 2))) | |
290 | (make-equal-hash-table-internal | |
291 | real-hash-table (new-vector (+ size nmisses)) | |
292 | hash-table-size size | |
293 | rehash-after-n-misses nmisses | |
294 | hash-table-rehash-size rhs | |
295 | hash-table-rehash-function rhf)) | |
296 | ||
297 | ; Gethash-equal either returns the value associated with that key in that | |
298 | ; hash table or nil if there is none. | |
299 | ||
300 | (defun gethash-equal (key hash-table &aux position-value) | |
301 | (do ((try-position (remainder (sxhash key) (hash-table-size hash-table)) | |
302 | (1+ try-position)) | |
303 | (n (rehash-after-n-misses hash-table) (1- n)) | |
304 | (real-hash-table (real-hash-table hash-table))) | |
305 | ((zerop n) nil) ;it is not there so just return nil | |
306 | (cond ((equal key | |
307 | (hash-key (setq position-value | |
308 | (vref real-hash-table try-position)))) | |
309 | (return (hash-value position-value)))))) | |
310 | ||
311 | (eval-when (eval compile load) | |
312 | (defsetf gethash-equal (e v) `(puthash-equal ,(cadr e) v ,(caddr e)))) | |
313 | ||
314 | ; Puthash inserts a hash-element for the given key and value in the | |
315 | ; hash table that is passed to it. If the key already exists in the hash | |
316 | ; table the value of that key is replaced by the new value. If it finds an | |
317 | ; empty space it adds a hash-element for that key and value into that | |
318 | ; space and increments hash-table-fullness by one. If it cannot find | |
319 | ; the key or an empty space in four tries then it calls rehash on the | |
320 | ; hash table and tries again. | |
321 | ||
322 | (declare (localf puthash-equal-internal)) | |
323 | ||
324 | (defun puthash-equal (key value hash-table) | |
325 | (puthash-equal-internal key value hash-table nil)) | |
326 | ||
327 | (defun swaphash-equal (key value hash-table) | |
328 | (puthash-equal-internal key value hash-table t)) | |
329 | ||
330 | (defun puthash-equal-internal (key value hash-table swap?) | |
331 | (do ((try-position (remainder (sxhash key) (hash-table-size hash-table)) | |
332 | (1+ try-position)) | |
333 | (n (rehash-after-n-misses hash-table) (1- n)) | |
334 | (real-hash-table (real-hash-table hash-table))) | |
335 | ((zerop n) ;if cannot find a place in n tries then rehash | |
336 | (funcall (hash-table-rehash-function hash-table) | |
337 | hash-table (hash-table-rehash-size hash-table)) | |
338 | (puthash-equal key value hash-table)) | |
339 | ||
340 | (cond ((or (equal (hash-key (vref real-hash-table try-position)) | |
341 | key) | |
342 | (and (null (vref real-hash-table try-position)) | |
343 | (setf (hash-table-fullness hash-table) | |
344 | (1+ (hash-table-fullness hash-table))))) | |
345 | (return | |
346 | (prog1 (if swap? (hash-value | |
347 | (vref real-hash-table try-position)) | |
348 | value) | |
349 | (setf (vref real-hash-table try-position) | |
350 | (make-hash-element key value)))))))) | |
351 | ||
352 | ||
353 | ; Remhash removes the hash-element associated with the given key from | |
354 | ; the hash table that is passed to it. If it finds the element and removes | |
355 | ; it then it returns the key. If it cannot find the element then it returns | |
356 | ; nil. | |
357 | ||
358 | (defun remhash-equal (key hash-table) | |
359 | (do ((try-position (remainder (sxhash key) (hash-table-size hash-table)) | |
360 | (1+ try-position)) | |
361 | (n (rehash-after-n-misses hash-table) (1- n)) | |
362 | (real-hash-table (real-hash-table hash-table))) | |
363 | ((zerop n) nil) ;not in the hash table return nil | |
364 | (cond ((equal (hash-key (vref real-hash-table try-position)) key) | |
365 | (setf (vref real-hash-table try-position) nil) | |
366 | (return key))))) ;return the key if found and removed | |
367 | ||
368 | ||
369 | ; Hash-table-rehash first saves the contents of the current hash table | |
370 | ; in a temporary vector then puthashes the elements of this temporary vector | |
371 | ; into the original hash-table after making it larger by a factor of | |
372 | ; the variable grow. | |
373 | ||
374 | (defun equal-hash-table-rehash (hash-table grow) | |
375 | (let* ((real-hash-table (real-hash-table hash-table)) | |
376 | (nmisses (rehash-after-n-misses hash-table)) | |
377 | (new-size (+ nmisses | |
378 | (hash-table-good-size (times grow | |
379 | (hash-table-size hash-table))))) | |
380 | (j 0) | |
381 | (temp-array (new-vector new-size))) | |
382 | (do ((current-position 0 (1+ current-position)) | |
383 | (old-size (+ (hash-table-size hash-table) nmisses))) | |
384 | ((>= current-position old-size)) | |
385 | (let ((current-hash-element (vref real-hash-table current-position))) | |
386 | (cond ((null current-hash-element)) | |
387 | (t (setf (vref temp-array j) current-hash-element) | |
388 | (setq j (1+ j)))))) | |
389 | (cond ((not (= grow 1)) ;if the hash table has grown | |
390 | (setf (real-hash-table hash-table) (new-vector new-size)) | |
391 | (setf (hash-table-fullness hash-table) 0) | |
392 | (setf (hash-table-size hash-table) (- new-size nmisses)))) | |
393 | (do ((position 0 (1+ position))) ;add old values to new table | |
394 | ((= position j)) | |
395 | (puthash (hash-key (vref temp-array position)) | |
396 | (hash-value (vref temp-array position)) | |
397 | hash-table)))) | |
398 | ||
399 | (defun maphash-equal (func hash-table) | |
400 | (let ((real-hash-table (real-hash-table hash-table))) | |
401 | (loop for num from 0 to (1- (vsize real-hash-table)) | |
402 | with keyword and value | |
403 | do (setq keyword (vref real-hash-table num)) | |
404 | unless (null keyword) | |
405 | do (progn (setq value (cdr keyword) | |
406 | keyword (car keyword)) | |
407 | (funcall func keyword value))))) | |
408 | ||
409 | (sstatus feature hash-tables) |