1 ;;;; that part of the implementation of HASH-TABLE which lives solely
2 ;;;; on the target system, not on the cross-compilation host
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!IMPL")
17 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
18 (defconstant max-hash sb
!xc
:most-positive-fixnum
))
21 `(integer 0 ,max-hash
))
23 ;;; FIXME: Does this always make a nonnegative FIXNUM? If so, then
24 ;;; explain why. If not (or if the reason it always makes a
25 ;;; nonnegative FIXNUM is only the accident that pointers in supported
26 ;;; architectures happen to be in the lower half of the address
27 ;;; space), then fix it.
28 #!-sb-fluid
(declaim (inline pointer-hash
))
29 (defun pointer-hash (key)
30 (declare (values hash
))
31 (truly-the hash
(%primitive sb
!c
:make-fixnum key
)))
33 #!-sb-fluid
(declaim (inline eq-hash
))
35 (declare (values hash
(member t nil
)))
36 (values (pointer-hash key
)
37 (oddp (get-lisp-obj-address key
))))
39 #!-sb-fluid
(declaim (inline equal-hash
))
40 (defun equal-hash (key)
41 (declare (values hash
(member t nil
)))
42 (values (sxhash key
) nil
))
44 #!-sb-fluid
(declaim (inline eql-hash
))
46 (declare (values hash
(member t nil
)))
51 (defun equalp-hash (key)
52 (declare (values hash
(member t nil
)))
53 (values (psxhash key
) nil
))
55 (defun almost-primify (num)
56 (declare (type index num
))
58 "Return an almost prime number greater than or equal to NUM."
67 ;;;; user-defined hash table tests
69 (defvar *hash-table-tests
* nil
)
71 (defun define-hash-table-test (name test-fun hash-fun
)
73 "Define a new kind of hash table test."
74 (declare (type symbol name
)
75 (type function test-fun hash-fun
))
76 (setf *hash-table-tests
*
77 (cons (list name test-fun hash-fun
)
78 (remove name
*hash-table-tests
* :test
#'eq
:key
#'car
)))
81 ;;;; construction and simple accessors
83 (defconstant +min-hash-table-size
+ 16)
84 (defconstant +min-hash-table-rehash-threshold
+ (float 1/16 1.0))
85 ;; as explained by pmai on openprojects #lisp IRC 2002-07-30: #x80000000
86 ;; is bigger than any possible nonEQ hash value, and thus indicates an
87 ;; empty slot; and EQ hash tables don't use HASH-TABLE-HASH-VECTOR
88 (defconstant +magic-hash-vector-value
+ #x80000000
)
90 (defun make-hash-table (&key
(test 'eql
)
91 (size +min-hash-table-size
+)
96 "Create and return a new hash table. The keywords are as follows:
97 :TEST -- Indicates what kind of test to use.
98 :SIZE -- A hint as to how many elements will be put in this hash
100 :REHASH-SIZE -- Indicates how to expand the table when it fills up.
101 If an integer, add space for that many elements. If a floating
102 point number (which must be greater than 1.0), multiply the size
104 :REHASH-THRESHOLD -- Indicates how dense the table can become before
105 forcing a rehash. Can be any positive number <=1, with density
106 approaching zero as the threshold approaches 0. Density 1 means an
107 average of one entry per bucket.
108 :WEAK-P -- (This is an extension from CMU CL, not currently supported
109 in SBCL 0.6.6, but perhaps supported in a future version.) If T,
110 don't keep entries if the key would otherwise be garbage."
111 (declare (type (or function symbol
) test
))
112 (declare (type unsigned-byte size
))
114 (error "stub: unsupported WEAK-P option"))
115 (multiple-value-bind (test test-fun hash-fun
)
116 (cond ((or (eq test
#'eq
) (eq test
'eq
))
117 (values 'eq
#'eq
#'eq-hash
))
118 ((or (eq test
#'eql
) (eq test
'eql
))
119 (values 'eql
#'eql
#'eql-hash
))
120 ((or (eq test
#'equal
) (eq test
'equal
))
121 (values 'equal
#'equal
#'equal-hash
))
122 ((or (eq test
#'equalp
) (eq test
'equalp
))
123 (values 'equalp
#'equalp
#'equalp-hash
))
125 ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff.
126 ;; Failing that, I'd like to rename it to
127 ;; *USER-HASH-TABLE-TESTS*.
128 (dolist (info *hash-table-tests
*
129 (error "unknown :TEST for MAKE-HASH-TABLE: ~S"
131 (destructuring-bind (test-name test-fun hash-fun
) info
132 (when (or (eq test test-name
) (eq test test-fun
))
133 (return (values test-name test-fun hash-fun
)))))))
134 (let* ((size (max +min-hash-table-size
+
136 ;; SIZE is just a hint, so if the user asks
137 ;; for a SIZE which'd be too big for us to
138 ;; easily implement, we bump it down.
139 (floor array-dimension-limit
1024))))
140 (rehash-size (if (integerp rehash-size
)
142 (float rehash-size
1.0)))
143 ;; FIXME: Original REHASH-THRESHOLD default should be 1.0,
144 ;; not 1, to make it easier for the compiler to avoid
146 (rehash-threshold (max +min-hash-table-rehash-threshold
+
147 (float rehash-threshold
1.0)))
148 (size+1 (1+ size
)) ; The first element is not usable.
149 ;; KLUDGE: The most natural way of expressing the below is
150 ;; (round (/ (float size+1) rehash-threshold)), and indeed
151 ;; it was expressed like that until 0.7.0. However,
152 ;; MAKE-HASH-TABLE is called very early in cold-init, and
153 ;; the SPARC has no primitive instructions for rounding,
154 ;; but only for truncating; therefore, we fudge this issue
155 ;; a little. The other uses of truncate, below, similarly
156 ;; used to be round. -- CSR, 2002-10-01
158 ;; Note that this has not yet been audited for
159 ;; correctness. It just seems to work. -- CSR, 2002-11-02
160 (scaled-size (truncate (/ (float size
+1) rehash-threshold
)))
161 (length (almost-primify (max scaled-size
162 (1+ +min-hash-table-size
+))))
163 (index-vector (make-array length
165 '(unsigned-byte #.sb
!vm
:n-word-bits
)
167 ;; needs to be the same length as the KV vector
168 ;; (FIXME: really? why doesn't the code agree?)
169 (next-vector (make-array size
+1
171 '(unsigned-byte #.sb
!vm
:n-word-bits
)))
172 (kv-vector (make-array (* 2 size
+1)
173 :initial-element
+empty-ht-slot
+))
174 (table (%make-hash-table
178 :rehash-size rehash-size
179 :rehash-threshold rehash-threshold
183 :index-vector index-vector
184 :next-vector next-vector
185 :hash-vector
(unless (eq test
'eq
)
187 :element-type
'(unsigned-byte #.sb
!vm
:n-word-bits
)
188 :initial-element
+magic-hash-vector-value
+)))))
189 (declare (type index size
+1 scaled-size length
))
190 ;; Set up the free list, all free. These lists are 0 terminated.
193 (setf (aref next-vector i
) (1+ i
)))
194 (setf (aref next-vector size
) 0)
195 (setf (hash-table-next-free-kv table
) 1)
196 (setf (hash-table-needing-rehash table
) 0)
197 (setf (aref kv-vector
0) table
)
200 (defun hash-table-count (hash-table)
202 "Return the number of entries in the given HASH-TABLE."
203 (declare (type hash-table hash-table
)
205 (hash-table-number-entries hash-table
))
208 (setf (fdocumentation 'hash-table-rehash-size
'function
)
209 "Return the rehash-size HASH-TABLE was created with.")
212 (setf (fdocumentation 'hash-table-rehash-threshold
'function
)
213 "Return the rehash-threshold HASH-TABLE was created with.")
215 (defun hash-table-size (hash-table)
217 "Return a size that can be used with MAKE-HASH-TABLE to create a hash
218 table that can hold however many entries HASH-TABLE can hold without
220 (hash-table-rehash-trigger hash-table
))
223 (setf (fdocumentation 'hash-table-test
'function
)
224 "Return the test HASH-TABLE was created with.")
227 (setf (fdocumentation 'hash-table-weak-p
'function
)
228 "Return T if HASH-TABLE will not keep entries for keys that would
229 otherwise be garbage, and NIL if it will.")
231 ;;;; accessing functions
233 ;;; Make new vectors for the table, extending the table based on the
235 (defun rehash (table)
236 (declare (type hash-table table
))
237 (let* ((old-kv-vector (hash-table-table table
))
238 (old-next-vector (hash-table-next-vector table
))
239 (old-hash-vector (hash-table-hash-vector table
))
240 (old-size (length old-next-vector
))
242 (let ((rehash-size (hash-table-rehash-size table
)))
243 (etypecase rehash-size
245 (+ rehash-size old-size
))
247 (the index
(truncate (* rehash-size old-size
)))))))
248 (new-kv-vector (make-array (* 2 new-size
)
249 :initial-element
+empty-ht-slot
+))
250 (new-next-vector (make-array new-size
251 :element-type
'(unsigned-byte #.sb
!vm
:n-word-bits
)
253 (new-hash-vector (when old-hash-vector
255 :element-type
'(unsigned-byte #.sb
!vm
:n-word-bits
)
256 :initial-element
+magic-hash-vector-value
+)))
257 (old-index-vector (hash-table-index-vector table
))
258 (new-length (almost-primify
259 (truncate (/ (float new-size
)
260 (hash-table-rehash-threshold table
)))))
261 (new-index-vector (make-array new-length
262 :element-type
'(unsigned-byte #.sb
!vm
:n-word-bits
)
263 :initial-element
0)))
264 (declare (type index new-size new-length old-size
))
266 ;; Disable GC tricks on the OLD-KV-VECTOR.
267 (set-header-data old-kv-vector sb
!vm
:vector-normal-subtype
)
269 ;; FIXME: here and in several other places in the hash table code,
270 ;; loops like this one are used when FILL or REPLACE would be
271 ;; appropriate. why are standard CL functions not used?
272 ;; Performance issues? General laziness? -- NJF, 2004-03-10
274 ;; Copy over the kv-vector. The element positions should not move
275 ;; in case there are active scans.
276 (dotimes (i (* old-size
2))
277 (declare (type index i
))
278 (setf (aref new-kv-vector i
) (aref old-kv-vector i
)))
280 ;; Copy over the hash-vector.
281 (when old-hash-vector
282 (dotimes (i old-size
)
283 (setf (aref new-hash-vector i
) (aref old-hash-vector i
))))
285 (setf (hash-table-next-free-kv table
) 0)
286 (setf (hash-table-needing-rehash table
) 0)
287 ;; Rehash all the entries; last to first so that after the pushes
288 ;; the chains are first to last.
289 (do ((i (1- new-size
) (1- i
)))
291 (let ((key (aref new-kv-vector
(* 2 i
)))
292 (value (aref new-kv-vector
(1+ (* 2 i
)))))
293 (cond ((and (eq key
+empty-ht-slot
+)
294 (eq value
+empty-ht-slot
+))
295 ;; Slot is empty, push it onto the free list.
296 (setf (aref new-next-vector i
)
297 (hash-table-next-free-kv table
))
298 (setf (hash-table-next-free-kv table
) i
))
299 ((and new-hash-vector
300 (not (= (aref new-hash-vector i
) +magic-hash-vector-value
+)))
301 ;; Can use the existing hash value (not EQ based)
302 (let* ((hashing (aref new-hash-vector i
))
303 (index (rem hashing new-length
))
304 (next (aref new-index-vector index
)))
305 (declare (type index index
)
307 ;; Push this slot into the next chain.
308 (setf (aref new-next-vector i
) next
)
309 (setf (aref new-index-vector index
) i
)))
313 (set-header-data new-kv-vector
314 sb
!vm
:vector-valid-hashing-subtype
)
315 (let* ((hashing (pointer-hash key
))
316 (index (rem hashing new-length
))
317 (next (aref new-index-vector index
)))
318 (declare (type index index
)
320 ;; Push this slot onto the next chain.
321 (setf (aref new-next-vector i
) next
)
322 (setf (aref new-index-vector index
) i
))))))
323 (setf (hash-table-table table
) new-kv-vector
)
324 (setf (hash-table-index-vector table
) new-index-vector
)
325 (setf (hash-table-next-vector table
) new-next-vector
)
326 (setf (hash-table-hash-vector table
) new-hash-vector
)
327 ;; Shrink the old vectors to 0 size to help the conservative GC.
328 (shrink-vector old-kv-vector
0)
329 (shrink-vector old-index-vector
0)
330 (shrink-vector old-next-vector
0)
331 (when old-hash-vector
332 (shrink-vector old-hash-vector
0))
333 (setf (hash-table-rehash-trigger table
) new-size
))
336 ;;; Use the same size as before, re-using the vectors.
337 (defun rehash-without-growing (table)
338 (declare (type hash-table table
))
339 (let* ((kv-vector (hash-table-table table
))
340 (next-vector (hash-table-next-vector table
))
341 (hash-vector (hash-table-hash-vector table
))
342 (size (length next-vector
))
343 (index-vector (hash-table-index-vector table
))
344 (length (length index-vector
)))
345 (declare (type index size length
))
347 ;; Disable GC tricks, they will be re-enabled during the re-hash
349 (set-header-data kv-vector sb
!vm
:vector-normal-subtype
)
351 ;; Rehash all the entries.
352 (setf (hash-table-next-free-kv table
) 0)
353 (setf (hash-table-needing-rehash table
) 0)
355 (setf (aref next-vector i
) 0))
357 (setf (aref index-vector i
) 0))
358 (do ((i (1- size
) (1- i
)))
360 (let ((key (aref kv-vector
(* 2 i
)))
361 (value (aref kv-vector
(1+ (* 2 i
)))))
362 (cond ((and (eq key
+empty-ht-slot
+)
363 (eq value
+empty-ht-slot
+))
364 ;; Slot is empty, push it onto free list.
365 (setf (aref next-vector i
) (hash-table-next-free-kv table
))
366 (setf (hash-table-next-free-kv table
) i
))
367 ((and hash-vector
(not (= (aref hash-vector i
) +magic-hash-vector-value
+)))
368 ;; Can use the existing hash value (not EQ based)
369 (let* ((hashing (aref hash-vector i
))
370 (index (rem hashing length
))
371 (next (aref index-vector index
)))
372 (declare (type index index
))
373 ;; Push this slot into the next chain.
374 (setf (aref next-vector i
) next
)
375 (setf (aref index-vector index
) i
)))
379 (set-header-data kv-vector sb
!vm
:vector-valid-hashing-subtype
)
380 (let* ((hashing (pointer-hash key
))
381 (index (rem hashing length
))
382 (next (aref index-vector index
)))
383 (declare (type index index
)
385 ;; Push this slot into the next chain.
386 (setf (aref next-vector i
) next
)
387 (setf (aref index-vector index
) i
)))))))
390 (defun flush-needing-rehash (table)
391 (let* ((kv-vector (hash-table-table table
))
392 (index-vector (hash-table-index-vector table
))
393 (next-vector (hash-table-next-vector table
))
394 (length (length index-vector
)))
395 (do ((next (hash-table-needing-rehash table
)))
397 (declare (type index next
))
398 (let* ((key (aref kv-vector
(* 2 next
)))
399 (hashing (pointer-hash key
))
400 (index (rem hashing length
))
401 (temp (aref next-vector next
)))
402 (setf (aref next-vector next
) (aref index-vector index
))
403 (setf (aref index-vector index
) next
)
405 (setf (hash-table-needing-rehash table
) 0)
408 (defun gethash (key hash-table
&optional default
)
410 "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
411 value and T as multiple values, or returns DEFAULT and NIL if there is no
412 such entry. Entries can be added using SETF."
413 (declare (type hash-table hash-table
)
414 (values t
(member t nil
)))
416 (cond ((= (get-header-data (hash-table-table hash-table
))
417 sb
!vm
:vector-must-rehash-subtype
)
418 (rehash-without-growing hash-table
))
419 ((not (zerop (hash-table-needing-rehash hash-table
)))
420 (flush-needing-rehash hash-table
)))
421 ;; Search for key in the hash table.
422 (multiple-value-bind (hashing eq-based
)
423 (funcall (hash-table-hash-fun hash-table
) key
)
424 (declare (type hash hashing
))
425 (let* ((index-vector (hash-table-index-vector hash-table
))
426 (length (length index-vector
))
427 (index (rem hashing length
))
428 (next (aref index-vector index
))
429 (table (hash-table-table hash-table
))
430 (next-vector (hash-table-next-vector hash-table
))
431 (hash-vector (hash-table-hash-vector hash-table
))
432 (test-fun (hash-table-test-fun hash-table
)))
433 (declare (type index index
))
434 ;; Search next-vector chain for a matching key.
435 (if (or eq-based
(not hash-vector
))
436 (do ((next next
(aref next-vector next
)))
437 ((zerop next
) (values default nil
))
438 (declare (type index next
))
439 (when (eq key
(aref table
(* 2 next
)))
440 (return (values (aref table
(1+ (* 2 next
))) t
))))
441 (do ((next next
(aref next-vector next
)))
442 ((zerop next
) (values default nil
))
443 (declare (type index next
))
444 (when (and (= hashing
(aref hash-vector next
))
445 (funcall test-fun key
(aref table
(* 2 next
))))
447 (return (values (aref table
(1+ (* 2 next
))) t
)))))))))
449 ;;; so people can call #'(SETF GETHASH)
450 (defun (setf gethash
) (new-value key table
&optional default
)
451 (declare (ignore default
))
452 (%puthash key table new-value
))
454 (defun %puthash
(key hash-table value
)
455 (declare (type hash-table hash-table
))
456 (aver (hash-table-index-vector hash-table
))
458 ;; We need to rehash here so that a current key can be found if it
459 ;; exists. Check that there is room for one more entry. May not be
460 ;; needed if the key is already present.
461 (cond ((zerop (hash-table-next-free-kv hash-table
))
463 ((= (get-header-data (hash-table-table hash-table
))
464 sb
!vm
:vector-must-rehash-subtype
)
465 (rehash-without-growing hash-table
))
466 ((not (zerop (hash-table-needing-rehash hash-table
)))
467 (flush-needing-rehash hash-table
)))
469 ;; Search for key in the hash table.
470 (multiple-value-bind (hashing eq-based
)
471 (funcall (hash-table-hash-fun hash-table
) key
)
472 (declare (type hash hashing
))
473 (let* ((index-vector (hash-table-index-vector hash-table
))
474 (length (length index-vector
))
475 (index (rem hashing length
))
476 (next (aref index-vector index
))
477 (kv-vector (hash-table-table hash-table
))
478 (next-vector (hash-table-next-vector hash-table
))
479 (hash-vector (hash-table-hash-vector hash-table
))
480 (test-fun (hash-table-test-fun hash-table
)))
481 (declare (type index index
))
483 (cond ((or eq-based
(not hash-vector
))
485 (set-header-data kv-vector sb
!vm
:vector-valid-hashing-subtype
))
487 ;; Search next-vector chain for a matching key.
488 (do ((next next
(aref next-vector next
)))
490 (declare (type index next
))
491 (when (eq key
(aref kv-vector
(* 2 next
)))
492 ;; Found, just replace the value.
493 (setf (aref kv-vector
(1+ (* 2 next
))) value
)
494 (return-from %puthash value
))))
496 ;; Search next-vector chain for a matching key.
497 (do ((next next
(aref next-vector next
)))
499 (declare (type index next
))
500 (when (and (= hashing
(aref hash-vector next
))
501 (funcall test-fun key
502 (aref kv-vector
(* 2 next
))))
503 ;; Found, just replace the value.
504 (setf (aref kv-vector
(1+ (* 2 next
))) value
)
505 (return-from %puthash value
)))))
507 ;; Pop a KV slot off the free list
508 (let ((free-kv-slot (hash-table-next-free-kv hash-table
)))
509 ;; Double-check for overflow.
510 (aver (not (zerop free-kv-slot
)))
511 (setf (hash-table-next-free-kv hash-table
)
512 (aref next-vector free-kv-slot
))
513 (incf (hash-table-number-entries hash-table
))
515 (setf (aref kv-vector
(* 2 free-kv-slot
)) key
)
516 (setf (aref kv-vector
(1+ (* 2 free-kv-slot
))) value
)
518 ;; Setup the hash-vector if necessary.
521 (setf (aref hash-vector free-kv-slot
) hashing
)
522 (aver (= (aref hash-vector free-kv-slot
) +magic-hash-vector-value
+))))
524 ;; Push this slot into the next chain.
525 (setf (aref next-vector free-kv-slot
) next
)
526 (setf (aref index-vector index
) free-kv-slot
)))))
529 (defun remhash (key hash-table
)
531 "Remove the entry in HASH-TABLE associated with KEY. Return T if there
532 was such an entry, or NIL if not."
533 (declare (type hash-table hash-table
)
534 (values (member t nil
)))
536 ;; We need to rehash here so that a current key can be found if it
538 (cond ((= (get-header-data (hash-table-table hash-table
))
539 sb
!vm
:vector-must-rehash-subtype
)
540 (rehash-without-growing hash-table
))
541 ((not (zerop (hash-table-needing-rehash hash-table
)))
542 (flush-needing-rehash hash-table
)))
544 ;; Search for key in the hash table.
545 (multiple-value-bind (hashing eq-based
)
546 (funcall (hash-table-hash-fun hash-table
) key
)
547 (declare (type hash hashing
))
548 (let* ((index-vector (hash-table-index-vector hash-table
))
549 (length (length index-vector
))
550 (index (rem hashing length
))
551 (next (aref index-vector index
))
552 (table (hash-table-table hash-table
))
553 (next-vector (hash-table-next-vector hash-table
))
554 (hash-vector (hash-table-hash-vector hash-table
))
555 (test-fun (hash-table-test-fun hash-table
)))
556 (declare (type index index next
))
557 (flet ((clear-slot (chain-vector prior-slot-location slot-location
)
558 ;; Mark slot as empty.
559 (setf (aref table
(* 2 slot-location
)) +empty-ht-slot
+
560 (aref table
(1+ (* 2 slot-location
))) +empty-ht-slot
+)
561 ;; Update the prior pointer in the chain to skip this.
562 (setf (aref chain-vector prior-slot-location
)
563 (aref next-vector slot-location
))
564 ;; Push KV slot onto free chain.
565 (setf (aref next-vector slot-location
)
566 (hash-table-next-free-kv hash-table
))
567 (setf (hash-table-next-free-kv hash-table
) slot-location
)
569 (setf (aref hash-vector slot-location
) +magic-hash-vector-value
+))
570 (decf (hash-table-number-entries hash-table
))
574 ((if (or eq-based
(not hash-vector
))
575 (eq key
(aref table
(* 2 next
)))
576 (and (= hashing
(aref hash-vector next
))
577 (funcall test-fun key
(aref table
(* 2 next
)))))
578 (clear-slot index-vector index next
))
579 ;; Search next-vector chain for a matching key.
580 ((or eq-based
(not hash-vector
))
582 (do ((prior next next
)
583 (next (aref next-vector next
) (aref next-vector next
)))
585 (declare (type index next
))
586 (when (eq key
(aref table
(* 2 next
)))
587 (return-from remhash
(clear-slot next-vector prior next
)))))
590 (do ((prior next next
)
591 (next (aref next-vector next
) (aref next-vector next
)))
593 (declare (type index next
))
594 (when (and (= hashing
(aref hash-vector next
))
595 (funcall test-fun key
(aref table
(* 2 next
))))
596 (return-from remhash
(clear-slot next-vector prior next
)))))))))))
598 (defun clrhash (hash-table)
600 "This removes all the entries from HASH-TABLE and returns the hash table
602 (declare (optimize speed
))
603 (let* ((kv-vector (hash-table-table hash-table
))
604 (next-vector (hash-table-next-vector hash-table
))
605 (hash-vector (hash-table-hash-vector hash-table
))
606 (size (length next-vector
))
607 (index-vector (hash-table-index-vector hash-table
)))
608 ;; Disable GC tricks.
609 (set-header-data kv-vector sb
!vm
:vector-normal-subtype
)
610 ;; Mark all slots as empty by setting all keys and values to magic
612 (aver (eq (aref kv-vector
0) hash-table
))
613 (fill kv-vector
+empty-ht-slot
+ :start
2)
614 ;; Set up the free list, all free.
617 (setf (aref next-vector i
) (1+ i
)))
618 (setf (aref next-vector
(1- size
)) 0)
619 (setf (hash-table-next-free-kv hash-table
) 1)
620 (setf (hash-table-needing-rehash hash-table
) 0)
621 ;; Clear the index-vector.
622 (fill index-vector
0)
623 ;; Clear the hash-vector.
625 (fill hash-vector
+magic-hash-vector-value
+)))
626 (setf (hash-table-number-entries hash-table
) 0)
631 ;;; FIXME: This should be made into a compiler transform for two reasons:
632 ;;; 1. It would then be available for compiling the entire system,
633 ;;; not only parts of the system which are defined after DEFUN MAPHASH.
634 ;;; 2. It could be conditional on compilation policy, so that
635 ;;; it could be compiled as a full call instead of an inline
636 ;;; expansion when SPACE>SPEED.
637 (declaim (inline maphash
))
638 (defun maphash (function-designator hash-table
)
640 "For each entry in HASH-TABLE, call the designated two-argument function
641 on the key and value of the entry. Return NIL."
642 (let ((fun (%coerce-callable-to-fun function-designator
))
643 (size (length (hash-table-next-vector hash-table
))))
644 (declare (type function fun
))
647 (declare (type index i
))
648 (let* ((kv-vector (hash-table-table hash-table
))
649 (key (aref kv-vector
(* 2 i
)))
650 (value (aref kv-vector
(1+ (* 2 i
)))))
651 (unless (and (eq key
+empty-ht-slot
+)
652 (eq value
+empty-ht-slot
+))
653 (funcall fun key value
))))))
655 ;;;; methods on HASH-TABLE
657 ;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE
658 ;;; when reconstructing HASH-TABLE.
659 (defun %hash-table-ctor-args
(hash-table)
660 (when (hash-table-weak-p hash-table
)
661 ;; FIXME: This might actually work with no trouble, but as of
662 ;; sbcl-0.6.12.10 when this code was written, weak hash tables
663 ;; weren't working yet, so I couldn't test it. When weak hash
664 ;; tables are supported again, this should be fixed.
665 (error "can't dump weak hash tables readably")) ; defensive programming..
666 `(:test
',(hash-table-test hash-table
)
667 :size
',(hash-table-size hash-table
)
668 :rehash-size
',(hash-table-rehash-size hash-table
)
669 :rehash-threshold
',(hash-table-rehash-threshold hash-table
)))
671 ;;; Return an association list representing the same data as HASH-TABLE.
672 (defun %hash-table-alist
(hash-table)
674 (maphash (lambda (key value
)
675 (push (cons key value
) result
))
679 ;;; Stuff an association list into HASH-TABLE. Return the hash table,
680 ;;; so that we can use this for the *PRINT-READABLY* case in
681 ;;; PRINT-OBJECT (HASH-TABLE T) without having to worry about LET
682 ;;; forms and readable gensyms and stuff.
683 (defun %stuff-hash-table
(hash-table alist
)
685 (setf (gethash (car x
) hash-table
) (cdr x
)))
688 (def!method print-object
((hash-table hash-table
) stream
)
689 (declare (type stream stream
))
690 (cond ((not *print-readably
*)
691 (print-unreadable-object (hash-table stream
:type t
:identity t
)
694 (hash-table-test hash-table
)
695 (hash-table-count hash-table
))))
697 (error "can't print hash tables readably without *READ-EVAL*"))
699 (with-standard-io-syntax
702 `(%stuff-hash-table
(make-hash-table ,@(%hash-table-ctor-args
704 ',(%hash-table-alist hash-table
)))))))
706 (def!method make-load-form
((hash-table hash-table
) &optional environment
)
707 (declare (ignore environment
))
708 (values `(make-hash-table ,@(%hash-table-ctor-args hash-table
))
709 `(%stuff-hash-table
,hash-table
',(%hash-table-alist hash-table
))))