![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to hash.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to hash.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 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:
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:
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)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.