/[cmucl]/src/code/hash.lisp
ViewVC logotype

Diff of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11 by wlott, Sat Dec 14 13:09:37 1991 UTC revision 1.11.1.1 by wlott, Tue Mar 3 08:20:40 1992 UTC
# Line 20  Line 20 
20            hash-table-count sxhash            hash-table-count sxhash
21            with-hash-table-iterator))            with-hash-table-iterator))
22    
23  ;;; Vector subtype codes.  ;;; Hash-values are all positive fixnums:
24    (deftype hash-value ()
25  (defconstant valid-hashing 2)    '(and fixnum (unsigned-byte)))
 (defconstant must-rehash 3)  
   
   
 ;;; What a hash-table is:  
26    
27  (defstruct (hash-table (:constructor make-hash-table-structure)  (defstruct (hash-table (:constructor make-hash-table-structure)
28                         (:conc-name hash-table-)                         (:conc-name hash-table-)
29                         (:print-function %print-hash-table)                         (:print-function %print-hash-table)
30                         (:make-load-form-fun make-hash-table-load-form))                         (:make-load-form-fun make-hash-table-load-form))
31    "Structure used to implement hash tables."    "Structure used to implement hash tables."
32    (kind 'eq)    (kind 'eq :type (member eq eql equal))
33    (size 65 :type fixnum)    (rehash-size 101 :type real)                  ; might be a float
   (rehash-size 101)                             ; might be a float  
34    (rehash-threshold 57 :type fixnum)    (rehash-threshold 57 :type fixnum)
35    (number-entries 0 :type fixnum)    (number-entries 0 :type fixnum)
36    (table (required-argument) :type simple-vector))    (table (required-argument) :type simple-vector)
37      (needing-rehash nil :type list))
38  ;;; A hash-table-table is a vector of association lists.  When an  ;;;
 ;;; entry is made in a hash table, a pair of (key . value) is consed onto  
 ;;; the element in the vector arrived at by hashing.  
   
 ;;; How to print one:  
   
39  (defun %print-hash-table (structure stream depth)  (defun %print-hash-table (structure stream depth)
40    (declare (ignore depth))    (declare (ignore depth))
41    (format stream "#<~A Hash Table {~X}>"    (format stream "#<~A Hash Table {~X}>"
# Line 53  Line 43 
43            (system:%primitive make-fixnum structure)))            (system:%primitive make-fixnum structure)))
44    
45    
46    (defstruct (hash-table-bucket
47                (:print-function %print-hash-table-bucket)
48                (:constructor %make-bucket (key hash value next)))
49      (key nil :type t)
50      (hash 0 :type hash-value)
51      (value nil :type t)
52      (next nil :type (or null hash-table-bucket))
53      (scavhook nil :type (or null scavenger-hook)))
54    ;;;
55    (defun %print-hash-table-bucket (bucket stream depth)
56      (declare (ignore depth))
57      (format stream "#<hash-table-bucket ~S->~S>"
58              (hash-table-bucket-key bucket)
59              (hash-table-bucket-value bucket)))
60    
61    (defun make-hash-table-bucket (table key hash value next scav-hook-p)
62      (declare (type hash-table table) (type hash-value hash)
63               (type (or null hash-table-bucket) next))
64      (let ((bucket (%make-bucket key hash value next)))
65        (when scav-hook-p
66          (setf (hash-table-bucket-scavhook bucket)
67                (make-scavenger-hook
68                 :value key
69                 :function #'(lambda ()
70                               (push bucket (hash-table-needing-rehash table))
71                               (setf (scavenger-hook-value
72                                      (hash-table-bucket-scavhook bucket))
73                                     nil)))))
74        bucket))
75    
76    
77    
78  ;;; Hashing functions for the three kinds of hash tables:  ;;; Hashing functions for the three kinds of hash tables:
79    
80  (eval-when (compile)  (eval-when (compile eval)
81    
82  (defmacro eq-hash (object)  (defmacro eq-hash (object)
83    "Gives us a hashing of an object such that (eq a b) implies    "Gives us a hashing of an object such that (eq a b) implies
84     (= (eq-hash a) (eq-hash b))"     (= (eq-hash a) (eq-hash b))"
85    `(truly-the (unsigned-byte 24) (%primitive make-fixnum ,object)))    `(values (truly-the hash-value (%primitive make-fixnum ,object))
86               t))
87    
88  (defmacro eql-hash (object)  (defmacro eql-hash (object)
89    "Gives us a hashing of an object such that (eql a b) implies    "Gives us a hashing of an object such that (eql a b) implies
90     (= (eql-hash a) (eql-hash b))"     (= (eql-hash a) (eql-hash b))"
91    `(if (numberp ,object)    `(if (numberp ,object)
92         (logand (truncate ,object) most-positive-fixnum)         (values (%eql-hash object) nil)
93         (truly-the fixnum (%primitive make-fixnum ,object))))         (eq-hash object)))
94    
95  (defmacro equal-hash (object)  (defmacro equal-hash (object)
96    "Gives us a hashing of an object such that (equal a b) implies    "Gives us a hashing of an object such that (equal a b) implies
97     (= (equal-hash a) (equal-hash b))"     (= (equal-hash a) (equal-hash b))"
98    `(sxhash ,object))    `(values (sxhash ,object) nil))
99    
100  )  )
101    
102    (defun %eql-hash (number)
103      (etypecase number
104        (fixnum
105         (logand number most-positive-fixnum))
106        (integer
107         (logand number most-positive-fixnum))
108        (float
109         (%eql-hash (integer-decode-float number)))
110        (ratio
111         (logxor (%eql-hash (numerator number))
112                 (%eql-hash (denominator number))))
113        (complex
114         (logxor (%eql-hash (realpart number))
115                 (%eql-hash (imagpart number))))))
116    
117    
118    (defun hash (table object)
119      (ecase (hash-table-kind table)
120        (eq (eq-hash object))
121        (eql (eql-hash object))
122        (equal (equal-hash object))))
123    
124    
125  ;;; Rehashing functions:  ;;; Rehashing functions:
126    
# Line 83  Line 128 
128    (declare (fixnum num))    (declare (fixnum num))
129    "Almost-Primify returns an almost prime number greater than or equal    "Almost-Primify returns an almost prime number greater than or equal
130     to NUM."     to NUM."
131    (if (= (rem num 2) 0)    (when (zerop (rem num 2))
132        (setq num (+ 1 num)))      (incf num))
133    (if (= (rem num 3) 0)    (when (zerop (rem num 3))
134        (setq num (+ 2 num)))      (incf num 2))
135    (if (= (rem num 7) 0)    (when (zerop (rem num 7))
136        (setq num (+ 4 num)))      (incf num 4))
137    num)    num)
138    
139  (eval-when (compile)  (defun rehash (table)
140      "Rehashes all the entries in the hash table TABLE.  Must only be called
141  (defmacro grow-size (table)     inside a WITHOUT-GCING."
142    "Returns a fixnum for the next size of a growing hash-table."    (let* ((old-vector (hash-table-table table))
143    `(let ((rehash-size (hash-table-rehash-size ,table)))           (old-length (length old-vector))
144       (if (floatp rehash-size)           (rehash-size (hash-table-rehash-size table))
145           (ceiling (* rehash-size (hash-table-size ,table)))           (new-length (if (floatp rehash-size)
146           (+ rehash-size (hash-table-size ,table)))))                           (ceiling (* rehash-size old-length))
147                             (+ rehash-size old-length)))
148  (defmacro grow-rehash-threshold (table new-length)           (new-vector (make-array new-length :initial-element nil)))
149    "Returns the next rehash threshold for the table."      (declare (type simple-vector old-vector new-vector)
150    table               (type index old-length new-length))
151    `,new-length      (flet ((reenter-bucket (bucket)
152  ;  `(ceiling (* (hash-table-rehash-threshold ,table)               (let ((key (hash-table-bucket-key bucket)))
153  ;              (/ ,new-length (hash-table-size ,table))))                 (multiple-value-bind
154    )                     (hashing needs-scav-hook)
155                       (hash table key)
156  (defmacro hash-set (vector key value length hashing-function)                   (let ((index (rem hashing new-length))
157    "Used for rehashing.  Enters the value for the key into the vector                         (value (hash-table-bucket-value bucket)))
158     by hashing.  Never grows the vector.  Assumes the key is not yet                     (setf (svref new-vector index)
159     entered."                           (make-hash-table-bucket table key hashing value
160    `(let ((index (rem (the fixnum (funcall ,hashing-function ,key))                                                   (svref new-vector index)
161                       (the fixnum ,length))))                                                   needs-scav-hook)))))))
162       (declare (fixnum index))        (dotimes (i old-length)
163       (setf (aref (the simple-vector ,vector) index)          (do ((bucket (aref old-vector i) (hash-table-bucket-next bucket)))
164             (cons (cons ,key ,value)              ((null bucket))
165                   (aref (the simple-vector ,vector) index)))))            (reenter-bucket bucket))
166            (setf (aref old-vector i) nil))
167          (dolist (bucket (hash-table-needing-rehash table))
168            (reenter-bucket bucket)))
169        (setf (hash-table-table table) new-vector)
170        (setf (hash-table-needing-rehash table) nil)
171        (when (> new-length old-length)
172          (setf (hash-table-rehash-threshold table) new-length))))
173    
174    (defun find-bucket (hash-table bucket-list key hashing)
175      (declare (type hash-table hash-table)
176               (type (or hash-table-bucket null) bucket-list)
177               (type hash-value hashing))
178      (flet ((frob (test)
179               (do ((prev nil bucket)
180                    (bucket bucket-list (hash-table-bucket-next bucket)))
181                   ((or (null bucket)
182                        (and (= hashing (hash-table-bucket-hash bucket))
183                             (funcall test (hash-table-bucket-key bucket) key)))
184                    (values bucket prev)))))
185        (declare (inline frob))
186        (ecase (hash-table-kind hash-table)
187          (equal (frob #'equal))
188          (eql (frob #'eql))
189          (eq (frob #'eq)))))
190    
191    (defun flush-needing-rehash (table)
192      (declare (type hash-table table))
193      (let* ((vector (hash-table-table table))
194             (length (length vector)))
195        (declare (type simple-vector vector)
196                 (type index length))
197        (dolist (bucket (hash-table-needing-rehash table))
198          (declare (type (or null hash-table-bucket) bucket))
199          (let ((index (rem (hash-table-bucket-hash bucket) length)))
200            (declare (type index index))
201            (do ((prev nil ptr)
202                 (ptr (svref vector index) (hash-table-bucket-next ptr)))
203                ((or (null bucket) (eq bucket ptr))
204                 (unless bucket
205                   (error "Can't find the bucket in the hash table.  ~
206                           Something is broken bigtime."))
207                 (if prev
208                     (setf (hash-table-bucket-next prev)
209                           (hash-table-bucket-next bucket))
210                     (setf (svref vector index)
211                           (hash-table-bucket-next bucket))))
212              (declare (type (or null hash-table-bucket) prev ptr))))
213          (let* ((key (hash-table-bucket-key bucket))
214                 (hashing (hash table key))
215                 (index (rem hashing length)))
216            (declare (type hash-value hashing) (type index index))
217            (setf (hash-table-bucket-next bucket) (svref vector index))
218            (setf (svref vector index) bucket)
219            (setf (scavenger-hook-value (hash-table-bucket-scavhook bucket)) key)
220            (setf (hash-table-bucket-hash bucket) hashing))))
221      (setf (hash-table-needing-rehash table) nil))
222    
 )  
223    
 (defun rehash (structure hash-vector new-length)  
   (declare (simple-vector hash-vector))  
   (declare (fixnum new-length))  
   "Rehashes a hash table and replaces the TABLE entry in the structure if  
    someone hasn't done so already.  New vector is of NEW-LENGTH."  
   (do ((new-vector (make-array new-length :initial-element nil))  
        (i 0 (1+ i))  
        (size (hash-table-size structure))  
        (hashing-function (case (hash-table-kind structure)  
                            (eq #'(lambda (x) (eq-hash x)))  
                            (eql #'(lambda (x) (eql-hash x)))  
                            (equal #'(lambda (x) (equal-hash x))))))  
       ((= i size)  
        (cond ((eq hash-vector (hash-table-table structure))  
               (cond ((> new-length size)  
                      (setf (hash-table-table structure) new-vector)  
                      (setf (hash-table-rehash-threshold structure)  
                            (grow-rehash-threshold structure new-length))  
                      (setf (hash-table-size structure) new-length))  
                     (t  
                      (setf (hash-table-table structure) new-vector)))  
               (if (not (eq (hash-table-kind structure) 'equal))  
                   (%primitive set-vector-subtype new-vector  
                               valid-hashing)))))  
     (declare (fixnum i size))  
     (do ((bucket (aref hash-vector i) (cdr bucket)))  
         ((null bucket))  
       (hash-set new-vector (caar bucket) (cdar bucket) new-length  
                 hashing-function))  
     (setf (aref hash-vector i) nil)))  
   
 ;;; Macros for Gethash, %Puthash, and Remhash:  
   
 (eval-when (compile)  
   
 ;;; Hashop dispatches on the kind of hash table we've got, rehashes if  
 ;;; necessary, and binds Vector to the hash vector, Index to the index  
 ;;; into that vector that the Key points to, and Size to the size of the  
 ;;; hash vector.  Since Equal hash tables only need to be maybe rehashed  
 ;;; sometimes, one can tell it if it's one of those times with the  
 ;;; Equal-Needs-To-Rehash-P argument.  
   
 (defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body)  
   `(let* ((vector (hash-table-table hash-table))  
           (size (length vector)))  
      (declare (simple-vector vector) (fixnum size)  
               (inline assoc))  
      (case (hash-table-kind hash-table)  
        (equal  
         ,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed)))  
         (let ((index (rem (the fixnum (equal-hash key)) size)))  
           (declare (fixnum index))  
           ,equal-body))  
        (eq  
         (without-gcing  
           (eq-rehash-if-needed)  
           (let ((index (rem (the fixnum (eq-hash key)) size)))  
             (declare (fixnum index))  
             ,eq-body)))  
        (eql  
         (without-gcing  
           (eq-rehash-if-needed)  
           (let ((index (rem (the fixnum (eql-hash key)) size)))  
             (declare (fixnum index))  
             ,eql-body))))))  
   
 (defmacro eq-rehash-if-needed ()  
   `(let ((subtype (truly-the (unsigned-byte 24)  
                              (%primitive get-vector-subtype vector))))  
      (declare (type (unsigned-byte 24) subtype))  
      (cond ((/= subtype valid-hashing)  
             (rehash hash-table vector size)  
             (setq vector (hash-table-table hash-table)))  
            ((> (hash-table-number-entries hash-table)  
                (hash-table-rehash-threshold hash-table))  
             (rehash hash-table vector (grow-size hash-table))  
             (setq vector (hash-table-table hash-table))  
             (setq size (length vector))))))  
   
 (defmacro equal-rehash-if-needed ()  
   `(cond ((> (hash-table-number-entries hash-table)  
              (hash-table-rehash-threshold hash-table))  
           (rehash hash-table vector (grow-size hash-table))  
           (setq vector (hash-table-table hash-table))  
           (setq size (length vector)))))  
   
 (defmacro rehash-if-needed ()  
   `(let ((subtype (truly-the (unsigned-byte 24)  
                              (%primitive get-vector-subtype vector)))  
          (size (length vector)))  
      (declare (type (unsigned-byte 24) subtype)  
               (fixnum size))  
      (cond ((and (not (eq (hash-table-kind hash-table) 'equal))  
                  (/= subtype valid-hashing))  
             (rehash hash-table vector size)  
             (setq vector (hash-table-table hash-table))  
             (setq size (length vector)))  
            ((> (hash-table-number-entries hash-table)  
                (hash-table-rehash-threshold hash-table))  
             (rehash hash-table vector (grow-size hash-table))  
             (setq vector (hash-table-table hash-table))  
             (setq size (length vector))))))  
   
 )  
224    
225  ;;; Making hash tables:  ;;; Making hash tables:
226    
227  (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)  (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)
228                               (rehash-threshold size))                               (rehash-threshold size))
229    "Creates and returns a hash table.  See manual for details."    "Creates and returns a hash table.  See manual for details."
230    (declare (type (or function (member eq eql equal)) test)    (declare (fixnum size))
231             (type index size rehash-size)    (let* ((test (cond ((eq test #'eq) 'eq)
232             (type (or (float 0.0 1.0) index) rehash-threshold))                       ((eq test #'eql) 'eql)
233    (let* ((test (cond ((or (eq test #'eq) (eq test 'eq)) 'eq)                       ((eq test #'equal) 'equal)
234                       ((or (eq test #'eql) (eq test 'eql)) 'eql)                       ((member test '(eq eql equal) :test #'eq)
235                       ((or (eq test #'equal) (eq test 'equal)) 'equal)                        test)
236                       (t                       (t
237                        (error "~S is an illegal :Test for hash tables." test))))                        (error "~S is an illegal :Test for hash tables." test))))
238           (size (if (<= size 37) 37 (almost-primify size)))           (size (if (<= size 37)
239           (rehash-threshold                     37
240            (cond ((and (fixnump rehash-threshold)                     (almost-primify size)))
241                        (<= 0 rehash-threshold size))           (rehash-threshold (cond ((null rehash-threshold)
242                   rehash-threshold)                                    size)
243                  ((and (floatp rehash-threshold)                                   ((floatp rehash-threshold)
244                        (<= 0.0 rehash-threshold 1.0))                                    (ceiling (* rehash-threshold size)))
245                   (ceiling (* rehash-threshold size)))                                   (t
246                  (t                                    rehash-threshold))))
247                   (error "Invalid rehash-threshold: ~S.~%Must be either a float ~    (make-hash-table-structure :rehash-size rehash-size
248                           between 0.0 and 1.0 ~%or an integer between 0 and ~D."                               :rehash-threshold rehash-threshold
249                          rehash-threshold                               :table (make-array size :initial-element nil)
250                          size))))                               :kind test)))
251           (table (make-array size :initial-element nil)))  
252      (make-hash-table-structure :size size  
                                :rehash-size rehash-size  
                                :rehash-threshold rehash-threshold  
                                :table  
                                (if (eq test 'equal)  
                                    table  
                                    (%primitive set-vector-subtype  
                                                table  
                                                valid-hashing))  
                                :kind test)))  
253    
254  ;;; Manipulating hash tables:  ;;; Manipulating hash tables:
255    
# Line 270  Line 257 
257    "Finds the entry in Hash-Table whose key is Key and returns the associated    "Finds the entry in Hash-Table whose key is Key and returns the associated
258     value and T as multiple values, or returns Default and Nil if there is no     value and T as multiple values, or returns Default and Nil if there is no
259     such entry."     such entry."
260    (macrolet ((lookup (test)    (without-gcing
261                 `(let ((cons (assoc key (aref vector index) :test #',test)))      (when (hash-table-needing-rehash hash-table)
262                    (declare (list cons))        (flush-needing-rehash hash-table))
263                    (if cons      (let* ((vector (hash-table-table hash-table))
264                        (values (cdr cons) t)             (size (length vector))
265                        (values default nil)))))             (hashing (hash hash-table key))
266      (hashop nil             (index (rem hashing size))
267        (lookup eq)             (bucket (find-bucket hash-table (svref vector index) key hashing)))
268        (lookup eql)        (if bucket
269        (lookup equal))))            (values (hash-table-bucket-value bucket) t)
270              (values default nil)))))
271    
272    
273  (defun %puthash (key hash-table value)  (defun %puthash (key hash-table value)
274    "Create an entry in HASH-TABLE associating KEY with VALUE; if there already    "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
275     is an entry for KEY, replace it.  Returns VALUE."     is an entry for KEY, replace it.  Returns VALUE."
276    (macrolet ((store (test)    (without-gcing
277                 `(let ((cons (assoc key (aref vector index) :test #',test)))      (cond ((> (hash-table-number-entries hash-table)
278                    (declare (list cons))                (hash-table-rehash-threshold hash-table))
279                    (cond (cons (setf (cdr cons) value))             (rehash hash-table))
280                          (t            ((hash-table-needing-rehash hash-table)
281                           (push (cons key value) (aref vector index))             (flush-needing-rehash hash-table)))
282                           (incf (hash-table-number-entries hash-table))      (let* ((vector (hash-table-table hash-table))
283                           value)))))             (size (length vector)))
284      (hashop t        (multiple-value-bind (hashing scav-hook-p) (hash hash-table key)
285        (store eq)          (let* ((index (rem hashing size))
286        (store eql)                 (bucket (find-bucket hash-table (svref vector index)
287        (store equal))))                                      key hashing)))
288              (if bucket
289                  (setf (hash-table-bucket-value bucket) value)
290                  (setf (svref vector index)
291                        (make-hash-table-bucket hash-table key hashing value
292                                                (svref vector index)
293                                                scav-hook-p)))))))
294      value)
295    
296  (defun remhash (key hash-table)  (defun remhash (key hash-table)
297    "Remove any entry for KEY in HASH-TABLE.  Returns T if such an entry    "Remove any entry for KEY in HASH-TABLE.  Returns T if such an entry
298     existed; () otherwise."     existed, and NIL if not."
299    (hashop nil    (without-gcing
300     (let ((bucket (aref vector index)))          ; EQ case      (when (hash-table-needing-rehash hash-table)
301       (cond ((and bucket (eq (caar bucket) key))        (flush-needing-rehash hash-table))
302              (pop (aref vector index))      (let* ((vector (hash-table-table hash-table))
303              (decf (hash-table-number-entries hash-table))             (size (length vector))
304              t)             (hashing (hash hash-table key))
305             (t             (index (rem hashing size)))
306              (do ((last bucket bucket)        (multiple-value-bind
307                   (bucket (cdr bucket) (cdr bucket)))            (bucket prev)
308                  ((null bucket) ())            (find-bucket hash-table (svref vector index) key hashing)
309                (when (eq (caar bucket) key)          (when bucket
310                  (rplacd last (cdr bucket))            (if prev
311                  (decf (hash-table-number-entries hash-table))                (setf (hash-table-bucket-next prev)
312                  (return t))))))                      (hash-table-bucket-next bucket))
313     (let ((bucket (aref vector index)))          ; EQL case                (setf (svref vector index)
314       (cond ((and bucket (eql (caar bucket) key))                      (hash-table-bucket-next bucket)))
315              (pop (aref vector index))            (decf (hash-table-number-entries hash-table))
316              (decf (hash-table-number-entries hash-table))            t)))))
317              t)  
318             (t  
             (do ((last bucket bucket)  
                  (bucket (cdr bucket) (cdr bucket)))  
                 ((null bucket) ())  
               (when (eql (caar bucket) key)  
                 (rplacd last (cdr bucket))  
                 (decf (hash-table-number-entries hash-table))  
                 (return t))))))  
    (let ((bucket (aref vector index)))          ; EQUAL case  
      (cond ((and bucket (equal (caar bucket) key))  
             (pop (aref vector index))  
             (decf (hash-table-number-entries hash-table))  
             t)  
            (t  
             (do ((last bucket bucket)  
                  (bucket (cdr bucket) (cdr bucket)))  
                 ((null bucket) ())  
               (when (equal (caar bucket) key)  
                 (rplacd last (cdr bucket))  
                 (decf (hash-table-number-entries hash-table))  
                 (return t))))))))  
   
319  (defun maphash (map-function hash-table)  (defun maphash (map-function hash-table)
320    "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value    "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
321    of the entry; returns T."    of the entry; returns T."
322    (let ((vector (hash-table-table hash-table)))    (let ((vector (hash-table-table hash-table)))
323      (declare (simple-vector vector))      (declare (simple-vector vector))
324      (rehash-if-needed)      (dotimes (index (length vector))
325      (do ((i 0 (1+ i))        (do ((bucket (aref vector index) (hash-table-bucket-next bucket)))
          (size (hash-table-size hash-table)))  
         ((= i size))  
       (declare (fixnum i size))  
       (do ((bucket (aref vector i) (cdr bucket)))  
326            ((null bucket))            ((null bucket))
327            (funcall map-function
328          (funcall map-function (caar bucket) (cdar bucket))))))                   (hash-table-bucket-key bucket)
329                     (hash-table-bucket-value bucket))))))
330    
331  (defun clrhash (hash-table)  (defun clrhash (hash-table)
332    "Removes all entries of HASH-TABLE and returns the hash table itself."    "Removes all entries of HASH-TABLE and returns the hash table itself."
333      (declare (type hash-table hash-table))
334    (let ((vector (hash-table-table hash-table)))    (let ((vector (hash-table-table hash-table)))
335      (declare (simple-vector vector))      (declare (simple-vector vector))
336      (setf (hash-table-number-entries hash-table) 0)      (setf (hash-table-number-entries hash-table) 0)
337      (do ((i 0 (1+ i))      (dotimes (i (length vector))
338           (size (hash-table-size hash-table)))        (setf (svref vector i) nil))
339          ((= i size) hash-table)      (setf (hash-table-needing-rehash hash-table) nil))
340        (declare (fixnum i size))    hash-table)
       (setf (aref vector i) nil))))  
341    
342  (defun hash-table-count (hash-table)  (defun hash-table-count (hash-table)
343    "Returns the number of entries in the given Hash-Table."    "Returns the number of entries in the given Hash-Table."
344    (hash-table-number-entries hash-table))    (hash-table-number-entries hash-table))
345    
346    
347    
348  ;;; Primitive Hash Function  ;;; Primitive Hash Function
349    
# Line 479  Line 453 
453     invocation, returns three values.  First, whether there are any more objects     invocation, returns three values.  First, whether there are any more objects
454     in the hash-table, second, the key, and third, the value."     in the hash-table, second, the key, and third, the value."
455    (let ((counter (gensym))    (let ((counter (gensym))
456          (pointer (gensym))          (bucket (gensym))
457          (table (gensym))          (table (gensym))
458          (size (gensym))          (size (gensym)))
459          (the-table (gensym)))      `(let* ((,table (hash-table-table ,hash-table))
460      `(let* ((,the-table ,hash-table)              (,size (length ,table))
             (,table (hash-table-table ,the-table))  
             (,size (hash-table-size ,the-table))  
461              (,counter 0)              (,counter 0)
462              (,pointer nil))              (,bucket (svref ,table 0)))
463           (declare (type index ,counter ,size)
464                    (type simple-vector ,table)
465                    (type (or null hash-table-bucket) ,bucket))
466         (macrolet ((,function ()         (macrolet ((,function ()
467                       `(loop                       `(loop
468                          (when (= ,',counter ,',size) (return))                          (when (= ,',counter ,',size)
469                          (let ((bucket (or ,',pointer                            (return))
470                                            (aref ,',table ,',counter))))                          (if ,',bucket
471                            (when bucket                              (return
472                              (cond ((cdr bucket)                               (multiple-value-prog1
473                                     (setf ,',pointer (cdr bucket)))                                   (values t
474                                    (t                                           (hash-table-bucket-key ,',bucket)
475                                     (setf ,',pointer nil)                                           (hash-table-bucket-value ,',bucket))
476                                     (incf ,',counter)))                                 (setf ,',bucket
477                              (return (values t (caar bucket) (cdar bucket)))))                                       (hash-table-bucket-next ,',bucket))))
478                          (incf ,',counter))))                              (setf ,',bucket
479                                      (svref ,table (incf ,',counter)))))))
480           ,@body))))           ,@body))))
481    
482    

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.11.1.1

  ViewVC Help
Powered by ViewVC 1.1.5