ViewVC logotype

Diff of /src/code/hash.lisp

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

revision 1.12 by wlott, Thu Apr 23 14:11:06 1992 UTC revision 1.13 by wlott, Thu May 7 08:48:08 1992 UTC
# Line 1  Line 1 
1  ;;; -*- Log: code.log; Package: Lisp -*-  ;;; -*- Package: CL -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
# Line 12  Line 12 
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
14  ;;; Hashing and hash table functions for Spice Lisp.  ;;; Hashing and hash table functions for Spice Lisp.
15  ;;; Written by Skef Wholey.  ;;; Originally written by Skef Wholey.
16    ;;; Everything except SXHASH rewritten by William Lott.
17  ;;;  ;;;
18  (in-package 'lisp)  (in-package :common-lisp)
20  (export '(hash-table hash-table-p make-hash-table  (export '(hash-table hash-table-p make-hash-table
21            gethash remhash maphash clrhash            gethash remhash maphash clrhash
22            hash-table-count sxhash            hash-table-count with-hash-table-iterator
23            with-hash-table-iterator))            hash-table-rehash-size hash-table-rehash-threshold
24              hash-table-size hash-table-test
25  ;;; Vector subtype codes.            sxhash))
 (defconstant valid-hashing 2)  
 (defconstant must-rehash 3)  
27  ;;; What a hash-table is:  
28    ;;;; The hash-table structure.
30  (defstruct (hash-table (:constructor make-hash-table-structure)  (defstruct (hash-table
31                         (:conc-name hash-table-)              (:constructor %make-hash-table)
32                         (:print-function %print-hash-table)              (:print-function %print-hash-table)
33                         (:make-load-form-fun make-hash-table-load-form))              (:make-load-form-fun make-hash-table-load-form))
34    "Structure used to implement hash tables."    "Structure used to implement hash tables."
35    (kind 'eq)    ;;
36    (size 65 :type fixnum)    ;; The type of hash table this is.  Only used for printing and as part of
37    (rehash-size 101)                             ; might be a float    ;; the exported interface.
38    (rehash-threshold 57 :type fixnum)    (test (required-argument) :type symbol :read-only t)
39    (number-entries 0 :type fixnum)    ;;
40      ;; The function used to compare two keys.  Returns T if they are the same
41      ;; and NIL if not.
42      (test-fun (required-argument) :type function :read-only t)
43      ;;
44      ;; The function used to compute the hashing of a key.  Returns two values:
45      ;; the index hashing and T if that might change with the next GC.
46      (hash-fun (required-argument) :type function :read-only t)
47      ;;
48      ;; How much to grow the hash table by when it fills up.  If an index, then
49      ;; add that amount.  If a floating point number, then multiple it by that.
50      (rehash-size (required-argument) :type (or index (float (1.0))) :read-only t)
51      ;;
52      ;; How full the hash table has to get before we rehash.
53      (rehash-threshold (required-argument) :type (real 0 1) :read-only t)
54      ;;
55      ;; (* rehash-threshold (length table)), saved here so we don't have to keep
56      ;; recomputing it.
57      (rehash-trigger (required-argument) :type index)
58      ;;
59      ;; The current number of entries in the table.
60      (number-entries 0 :type index)
61      ;;
62      ;; Vector of ht-buckets.
63    (table (required-argument) :type simple-vector))    (table (required-argument) :type simple-vector))
64    ;;;
65  ;;; A hash-table-table is a vector of association lists.  When an  (defun %print-hash-table (ht stream depth)
 ;;; 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:  
 (defun %print-hash-table (structure stream depth)  
66    (declare (ignore depth))    (declare (ignore depth))
67    (format stream "#<~A Hash Table {~X}>"    (print-unreadable-object (ht stream :identity t)
68            (symbol-name (hash-table-kind structure))      (format stream "~A hash table, ~D entries"
69            (system:%primitive make-fixnum structure)))              (symbol-name (hash-table-test ht))
70                (hash-table-number-entries ht))))
72    (defconstant max-hash most-positive-fixnum)
74    (deftype hash ()
75      `(integer 0 ,max-hash))
78    (defstruct hash-table-bucket
79      ;;
80      ;; The hashing associated with key, kept around so we don't have to recompute
81      ;; it each time.  When NIL, then just use %primitive make-fixnum.  We don't
82      ;; cache the results of make-fixnum, because it can change with a GC.
83      (hash nil :type (or hash null))
84      ;;
85      ;; The key and value, originally supplied by the user.
86      (key nil :type t)
87      (value nil :type t)
88      ;;
89      ;; The next bucket, or NIL if there are no more.
90      (next nil :type (or hash-table-bucket null)))
94  ;;; Hashing functions for the three kinds of hash tables:  ;;;; Utility functions.
96  (eval-when (compile)  (declaim (inline pointer-hash))
97    (defun pointer-hash (key)
98      (declare (values hash))
99      (truly-the hash (%primitive make-fixnum key)))
101    (declaim (inline eq-hash))
102    (defun eq-hash (key)
103      (declare (values hash (member t nil)))
104      (values (pointer-hash key)
105              (oddp (get-lisp-obj-address key))))
107    (declaim (inline eql-hash))
108    (defun eql-hash (key)
109      (declare (values hash (member t nil)))
110      (if (numberp key)
111          (equal-hash key)
112          (eq-hash key)))
114    (declaim (inline equal-hash))
115    (defun equal-hash (key)
116      (declare (values hash (member t nil)))
117      (values (sxhash key) nil))
 (defmacro eq-hash (object)  
   "Gives us a hashing of an object such that (eq a b) implies  
    (= (eq-hash a) (eq-hash b))"  
   `(truly-the (unsigned-byte 24) (%primitive make-fixnum ,object)))  
 (defmacro eql-hash (object)  
   "Gives us a hashing of an object such that (eql a b) implies  
    (= (eql-hash a) (eql-hash b))"  
   `(if (numberp ,object)  
        (logand (truncate ,object) most-positive-fixnum)  
        (truly-the fixnum (%primitive make-fixnum ,object))))  
 (defmacro equal-hash (object)  
   "Gives us a hashing of an object such that (equal a b) implies  
    (= (equal-hash a) (equal-hash b))"  
   `(sxhash ,object))  
 ;;; Rehashing functions:  
120  (defun almost-primify (num)  (defun almost-primify (num)
121    (declare (fixnum num))    (declare (type index num))
122    "Almost-Primify returns an almost prime number greater than or equal    "Almost-Primify returns an almost prime number greater than or equal
123     to NUM."     to NUM."
124    (if (= (rem num 2) 0)    (if (= (rem num 2) 0)
# Line 91  Line 129 
129        (setq num (+ 4 num)))        (setq num (+ 4 num)))
130    num)    num)
 (eval-when (compile)  
 (defmacro grow-size (table)  
   "Returns a fixnum for the next size of a growing hash-table."  
   `(let ((rehash-size (hash-table-rehash-size ,table)))  
      (if (floatp rehash-size)  
          (ceiling (* rehash-size (hash-table-size ,table)))  
          (+ rehash-size (hash-table-size ,table)))))  
 (defmacro grow-rehash-threshold (table new-length)  
   "Returns the next rehash threshold for the table."  
 ;  `(ceiling (* (hash-table-rehash-threshold ,table)  
 ;              (/ ,new-length (hash-table-size ,table))))  
 (defmacro hash-set (vector key value length hashing-function)  
   "Used for rehashing.  Enters the value for the key into the vector  
    by hashing.  Never grows the vector.  Assumes the key is not yet  
   `(let ((index (rem (the fixnum (funcall ,hashing-function ,key))  
                      (the fixnum ,length))))  
      (declare (fixnum index))  
      (setf (aref (the simple-vector ,vector) index)  
            (cons (cons ,key ,value)  
                  (aref (the simple-vector ,vector) index)))))  
 (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))  
                      (setf (hash-table-table structure) new-vector)))  
               (if (not (eq (hash-table-kind structure) 'equal))  
                   (%primitive set-vector-subtype new-vector  
     (declare (fixnum i size))  
     (do ((bucket (aref hash-vector i) (cdr bucket)))  
         ((null bucket))  
       (hash-set new-vector (caar bucket) (cdar bucket) new-length  
     (setf (aref hash-vector i) nil)))  
134  ;;; Macros for Gethash, %Puthash, and Remhash:  ;;;; Construction and simple accessors.
136    ;;; MAKE-HASH-TABLE -- public.
137    ;;;
138    (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
139                                 (rehash-threshold 1))
140      "Creates and returns a new hash table.  The keywords are as follows:
141         :TEST -- Indicates what kind of test to use.  Only EQ, EQL, and EQUAL
142           are currently supported.
143         :SIZE -- A hint as to how many elements will be put in this hash
144           table.
145         :REHASH-SIZE -- Indicates how to expand the table when it fills up.
146           If an integer, add space for that many elements.  If a floating
147           point number (which must be greater than 1.0), multiple the size
148           by that amount.
149         :REHASH-THRESHOLD -- Indicates how dense the table can become before
150           forcing a rehash.  Can be any real number between 0 and 1 (inclusive)."
151      (declare (type (or function (member eq eql equal)) test)
152               (type index size)
153               (type (or index (float (1.0))) rehash-size)
154               (type (real 0 1) rehash-threshold))
155      (multiple-value-bind
156          (test test-fun hash-fun)
157          (cond ((or (eq test #'eq) (eq test 'eq))
158                 (values 'eq #'eq #'eq-hash))
159                ((or (eq test #'eql) (eq test 'eql))
160                 (values 'eql #'eql #'eql-hash))
161                ((or (eq test #'equal) (eq test 'equal))
162                 (values 'equal #'equal #'equal-hash))
163                (t
164                 (error "Unknown :TEST for MAKE-HASH-TABLE: ~S" test)))
165        (let* ((size (ceiling size rehash-threshold))
166               (length (if (<= size 37) 37 (almost-primify size)))
167               (vector (make-array length :initial-element nil)))
168          (make-hash-table-structure
169           :test test
170           :test-fun test-fun
171           :hash-fun hash-fun
172           :rehash-size rehash-size
173           :rehash-threshold rehash-threshold
174           :rehash-trigger (* size rehash-threshold)
175           :table vector))))
177    (defun hash-table-count (hash-table)
178      "Returns the number of entries in the given HASH-TABLE."
179      (declare (type hash-table hash-table)
180               (values index))
181      (hash-table-number-entries hash-table))
183  (eval-when (compile)  (setf (documentation 'hash-table-rehash-size 'function)
184          "Return the rehash-size HASH-TABLE was created with.")
186  ;;; Hashop dispatches on the kind of hash table we've got, rehashes if  (setf (documentation 'hash-table-rehash-threshold 'function)
187  ;;; necessary, and binds Vector to the hash vector, Index to the index        "Return the rehash-threshold HASH-TABLE was created with.")
 ;;; 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)  
         ,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed)))  
         (let ((index (rem (the fixnum (equal-hash key)) size)))  
           (declare (fixnum index))  
           (let ((index (rem (the fixnum (eq-hash key)) size)))  
             (declare (fixnum index))  
           (let ((index (rem (the fixnum (eql-hash key)) size)))  
             (declare (fixnum index))  
 (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))))))  
189  )  (defun hash-table-size (hash-table)
190      "Return a size that can be used with MAKE-HASH-TABLE to create a hash
191  ;;; Making hash tables:     table that can hold however many entries HASH-TABLE can hold without
192       having to be grown."
193      (hash-table-rehash-trigger hash-table))
195    (setf (documentation 'hash-table-test 'function)
196          "Return the test HASH-TABLE was created with.")
 (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)  
                              (rehash-threshold size))  
   "Creates and returns a hash table.  See manual for details."  
   (declare (type (or function (member eq eql equal)) test)  
            (type index size rehash-size)  
            (type (or (float 0.0 1.0) index) rehash-threshold))  
   (let* ((test (cond ((or (eq test #'eq) (eq test 'eq)) 'eq)  
                      ((or (eq test #'eql) (eq test 'eql)) 'eql)  
                      ((or (eq test #'equal) (eq test 'equal)) 'equal)  
                       (error "~S is an illegal :Test for hash tables." test))))  
          (size (if (<= size 37) 37 (almost-primify size)))  
           (cond ((and (fixnump rehash-threshold)  
                       (<= 0 rehash-threshold size))  
                 ((and (floatp rehash-threshold)  
                       (<= 0.0 rehash-threshold 1.0))  
                  (ceiling (* rehash-threshold size)))  
                  (error "Invalid rehash-threshold: ~S.~%Must be either a float ~  
                          between 0.0 and 1.0 ~%or an integer between 0 and ~D."  
          (table (make-array size :initial-element nil)))  
     (make-hash-table-structure :size size  
                                :rehash-size rehash-size  
                                :rehash-threshold rehash-threshold  
                                (if (eq test 'equal)  
                                    (%primitive set-vector-subtype  
                                :kind test)))  
199  ;;; Manipulating hash tables:  ;;;; Accessing functions.
201    ;;; REHASH -- internal.
202    ;;;
203    ;;; Make a new vector for TABLE.  If GROW is NIL, use the same size as before,
204    ;;; otherwise extend the table based on the rehash-size.
205    ;;;
206    (defun rehash (table grow)
207      (declare (type hash-table table))
208      (let* ((old-vector (hash-table-table table))
209             (old-length (length old-vector))
210             (new-length
211              (if grow
212                  (let ((rehash-size (hash-table-rehash-size table)))
213                    (etypecase rehash-size
214                      (fixnum
215                       (+ rehash-size old-length))
216                      (float
217                       (ceiling (* rehash-size old-length)))))
218                  old-length))
219             (new-vector (make-array new-length :initial-element nil)))
220        (dotimes (i old-length)
221          (do ((bucket (svref old-vector i) next)
222               (next nil))
223              ((null bucket))
224            (setf next (hash-table-bucket-next bucket))
225            (let* ((old-hashing (hash-table-bucket-hash bucket))
226                   (hashing (cond
227                             (old-hashing old-hashing)
228                             (t
229                              (set-header-data new-vector
230                                               vm:vector-valid-hashing-subtype)
231                              (pointer-hash (hash-table-bucket-key bucket)))))
232                   (index (rem hashing new-length)))
233              (setf (hash-table-bucket-next bucket) (svref new-vector index))
234              (setf (svref new-vector index) bucket)))
235          ;; We clobber the old vector contents so that if it is living in
236          ;; static space it won't keep ahold of pointers into dynamic space.
237          (setf (svref old-vector i) nil))
238        (setf (hash-table-table table) new-vector)
239        (unless (= new-length old-length)
240          (setf (hash-table-rehash-trigger table)
241                (let ((threshold (hash-table-rehash-threshold table)))
242                  ;; Optimize the threshold=1 case so we don't have to use
243                  ;; generic arithmetic in the most common case.
244                  (if (eql threshold 1)
245                      new-length
246                      (truncate (* threshold new-length)))))))
247      (undefined-value))
249    ;;; GETHASH -- Public.
250    ;;;
251  (defun gethash (key hash-table &optional default)  (defun gethash (key hash-table &optional default)
252    "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
253     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
254     such entry."     such entry.  Entries can be added using SETF."
255    (macrolet ((lookup (test)    (declare (type hash-table hash-table)
256                 `(let ((cons (assoc key (aref vector index) :test #',test)))             (values t (member t nil)))
257                    (declare (list cons))    (without-gcing
258                    (if cons     (when (= (get-header-data (hash-table-table hash-table))
259                        (values (cdr cons) t)              vm:vector-must-rehash-subtype)
260                        (values default nil)))))       (rehash hash-table nil))
261      (hashop nil     (let* ((vector (hash-table-table hash-table))
262        (lookup eq)            (length (length vector))
263        (lookup eql)            (hashing (funcall (hash-table-hash-fun hash-table) key))
264        (lookup equal))))            (index (rem hashing length))
265              (test-fun (hash-table-test-fun hash-table)))
266         (do ((bucket (svref vector index) (hash-table-bucket-next bucket)))
267             ((null bucket) (values default nil))
268           (let ((bucket-hashing (hash-table-bucket-hash bucket)))
269             (when (if bucket-hashing
270                       (and (= bucket-hashing hashing)
271                            (funcall test-fun key (hash-table-bucket-key bucket)))
272                       (eq key (hash-table-bucket-key bucket)))
273               (return (values (hash-table-bucket-value bucket) t))))))))
275    ;;; %PUTHASH -- public setf method.
276    ;;;
277  (defun %puthash (key hash-table value)  (defun %puthash (key hash-table value)
278    "Create an entry in HASH-TABLE associating KEY with VALUE; if there already    (declare (type hash-table hash-table))
279     is an entry for KEY, replace it.  Returns VALUE."    (without-gcing
280    (macrolet ((store (test)     (let ((entries (1+ (hash-table-number-entries hash-table))))
281                 `(let ((cons (assoc key (aref vector index) :test #',test)))       (setf (hash-table-number-entries hash-table) entries)
282                    (declare (list cons))       (cond ((> entries (hash-table-rehash-trigger hash-table))
283                    (cond (cons (setf (cdr cons) value))              (rehash hash-table t))
284                          (t             ((= (get-header-data (hash-table-table hash-table))
285                           (push (cons key value) (aref vector index))                 vm:vector-must-rehash-subtype)
286                           (incf (hash-table-number-entries hash-table))              (rehash hash-table nil))))
287                           value)))))     (multiple-value-bind
288      (hashop t         (hashing eq-based)
289        (store eq)         (funcall (hash-table-hash-fun hash-table) key)
290        (store eql)       (let* ((vector (hash-table-table hash-table))
291        (store equal))))              (length (length vector))
292                (index (rem hashing length))
293                (first-bucket (svref vector index))
294                (test-fun (hash-table-test-fun hash-table)))
295           (do ((bucket first-bucket (hash-table-bucket-next bucket)))
296               ((null bucket)
297                (setf (svref vector index)
298                      (make-hash-table-bucket
299                       :hash (unless eq-based hashing)
300                       :key key
301                       :value value
302                       :next first-bucket)))
303             (let ((bucket-hashing (hash-table-bucket-hash bucket)))
304               (when (if bucket-hashing
305                         (and (= bucket-hashing hashing)
306                              (funcall test-fun
307                                       key (hash-table-bucket-key bucket)))
308                         (eq key (hash-table-bucket-key bucket)))
309                 (setf (hash-table-bucket-value bucket) value)
310                 (decf (hash-table-number-entries hash-table))
311                 (return)))))))
312      value)
314    ;;; REMHASH -- public.
315    ;;;
316  (defun remhash (key hash-table)  (defun remhash (key hash-table)
317    "Remove any entry for KEY in HASH-TABLE.  Returns T if such an entry    "Remove the entry in HASH-TABLE associated with KEY.  Returns T if there
318     existed; () otherwise."     was such an entry, and NIL if not."
319    (hashop nil    (declare (type hash-table hash-table)
320     (let ((bucket (aref vector index)))          ; EQ case             (values (member t nil)))
321       (cond ((and bucket (eq (caar bucket) key))    (without-gcing
322              (pop (aref vector index))     (when (= (get-header-data (hash-table-table hash-table))
323              (decf (hash-table-number-entries hash-table))              vm:vector-must-rehash-subtype)
324              t)       (rehash hash-table nil))
325             (t     (let* ((vector (hash-table-table hash-table))
326              (do ((last bucket bucket)            (length (length vector))
327                   (bucket (cdr bucket) (cdr bucket)))            (hashing (funcall (hash-table-hash-fun hash-table) key))
328                  ((null bucket) ())            (index (rem hashing length))
329                (when (eq (caar bucket) key)            (test-fun (hash-table-test-fun hash-table)))
330                  (rplacd last (cdr bucket))       (do ((prev nil bucket)
331                  (decf (hash-table-number-entries hash-table))            (bucket (svref vector index) (hash-table-bucket-next bucket)))
332                  (return t))))))           ((null bucket) nil)
333     (let ((bucket (aref vector index)))          ; EQL case         (let ((bucket-hashing (hash-table-bucket-hash bucket)))
334       (cond ((and bucket (eql (caar bucket) key))           (when (if bucket-hashing
335              (pop (aref vector index))                     (and (= bucket-hashing hashing)
336              (decf (hash-table-number-entries hash-table))                          (funcall test-fun key (hash-table-bucket-key bucket)))
337              t)                     (eq key (hash-table-bucket-key bucket)))
338             (t             (if prev
339              (do ((last bucket bucket)                 (setf (hash-table-bucket-next prev)
340                   (bucket (cdr bucket) (cdr bucket)))                       (hash-table-bucket-next bucket))
341                  ((null bucket) ())                 (setf (svref vector index)
342                (when (eql (caar bucket) key)                       (hash-table-bucket-next bucket)))
343                  (rplacd last (cdr bucket))             (return t)))))))
344                  (decf (hash-table-number-entries hash-table))  
345                  (return t))))))  ;;; CLRHASH -- public.
346     (let ((bucket (aref vector index)))          ; EQUAL case  ;;;
347       (cond ((and bucket (equal (caar bucket) key))  (defun clrhash (hash-table)
348              (pop (aref vector index))    "This removes all the entries from HASH-TABLE and returns the hash table
349              (decf (hash-table-number-entries hash-table))     itself."
350              t)    (let ((vector (hash-table-table hash-table)))
351             (t      (dotimes (i (length vector))
352              (do ((last bucket bucket)        (setf (aref vector i) nil))
353                   (bucket (cdr bucket) (cdr bucket)))      (setf (hash-table-number-entries hash-table) 0)
354                  ((null bucket) ())      (set-header-data vector vm:vector-normal-subtype))
355                (when (equal (caar bucket) key)    hash-table)
356                  (rplacd last (cdr bucket))  
357                  (decf (hash-table-number-entries hash-table))  
                 (return t))))))))  
361    (declaim (maybe-inline maphash))
362  (defun maphash (map-function hash-table)  (defun maphash (map-function hash-table)
363    "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
364    of the entry; returns NIL."     of the entry; returns NIL."
365    (let ((vector (hash-table-table hash-table)))    (declare (type (or function symbol) map-function)
366      (declare (simple-vector vector))             (type hash-table hash-table))
367      (rehash-if-needed)    (let ((fun (etypecase map-function
368      (do ((i 0 (1+ i))                 (function
369           (size (hash-table-size hash-table)))                  map-function)
370          ((= i size))                 (symbol
371        (declare (fixnum i size))                  (symbol-function map-function))))
372        (do ((bucket (aref vector i) (cdr bucket)))          (vector (hash-table-table hash-table)))
373        (dotimes (i (length vector))
374          (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))
375            ((null bucket))            ((null bucket))
376            (funcall fun
377          (funcall map-function (caar bucket) (cdar bucket))))))                   (hash-table-bucket-key bucket)
378                     (hash-table-bucket-value bucket))))))
381    (defmacro with-hash-table-iterator ((function hash-table) &body body)
382      "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
383       provides a method of manually looping over the elements of a hash-table.
384       function is bound to a generator-macro that, withing the scope of the
385       invocation, returns three values.  First, whether there are any more objects
386       in the hash-table, second, the key, and third, the value."
387      (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-")))
388        `(let ((,n-function
389                (let* ((table ,hash-table)
390                       (vector (hash-table-table table))
391                       (length (length vector))
392                       (index 0)
393                       (bucket (svref vector 0)))
394                  (labels
395                      ((,function ()
396                         (cond
397                          (bucket
398                           (multiple-value-prog1
399                               (values t
400                                       (hash-table-bucket-key bucket)
401                                       (hash-table-bucket-value bucket))
402                             (setf bucket (hash-table-bucket-next bucket))))
403                          ((= (incf index) length)
404                           (values nil))
405                          (t
406                           (setf bucket (svref vector index))
407                           (,function)))))
408                    #',function))))
409           (macrolet ((,function () (funcall ,n-function)))
410             ,@body))))
 (defun clrhash (hash-table)  
   "Removes all entries of HASH-TABLE and returns the hash table itself."  
   (let ((vector (hash-table-table hash-table)))  
     (declare (simple-vector vector))  
     (setf (hash-table-number-entries hash-table) 0)  
     (do ((i 0 (1+ i))  
          (size (hash-table-size hash-table)))  
         ((= i size) hash-table)  
       (declare (fixnum i size))  
       (setf (aref vector i) nil))))  
 (defun hash-table-count (hash-table)  
   "Returns the number of entries in the given Hash-Table."  
   (hash-table-number-entries hash-table))  
414  ;;; Primitive Hash Function  ;;;; SXHASH and support functions
416  ;;; The maximum length and depth to which we hash lists.  ;;; The maximum length and depth to which we hash lists.
417  (defconstant sxhash-max-len 7)  (defconstant sxhash-max-len 7)
# Line 470  Line 510 
 (defmacro with-hash-table-iterator ((function hash-table) &body body)  
   "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)  
    provides a method of manually looping over the elements of a hash-table.  
    function is bound to a generator-macro that, withing the scope of the  
    invocation, returns three values.  First, whether there are any more objects  
    in the hash-table, second, the key, and third, the value."  
   (let ((counter (gensym))  
         (pointer (gensym))  
         (table (gensym))  
         (size (gensym))  
         (the-table (gensym)))  
     `(let* ((,the-table ,hash-table)  
             (,table (hash-table-table ,the-table))  
             (,size (hash-table-size ,the-table))  
             (,counter 0)  
             (,pointer nil))  
        (macrolet ((,function ()  
                         (when (= ,',counter ,',size) (return))  
                         (let ((bucket (or ,',pointer  
                                           (aref ,',table ,',counter))))  
                           (when bucket  
                             (cond ((cdr bucket)  
                                    (setf ,',pointer (cdr bucket)))  
                                    (setf ,',pointer nil)  
                                    (incf ,',counter)))  
                             (return (values t (caar bucket) (cdar bucket)))))  
                         (incf ,',counter))))  
513  ;;;; Dumping one as a constant.  ;;;; Dumping one as a constant.
515  (defun make-hash-table-load-form (table)  (defun make-hash-table-load-form (table)
516    (values    (values
517     `(make-hash-table     `(make-hash-table
518       :test ',(hash-table-kind table) :size ',(hash-table-size table)       :test ',(hash-table-test table) :size ',(hash-table-size table)
519       :hash-table-rehash-size ',(hash-table-rehash-size table)       :hash-table-rehash-size ',(hash-table-rehash-size table)
520       :hash-table-rehash-threshold ',(hash-table-rehash-threshold table))       :hash-table-rehash-threshold ',(hash-table-rehash-threshold table))
521     (let ((sets nil))     (let ((sets nil))
522       (with-hash-table-iterator (next table)       (declare (inline maphash))
523         (loop       (maphash #'(lambda (key value)
524           (multiple-value-bind (more key value) (next)                    (setf sets (list* `(gethash ',key ,table) `',value sets)))
525             (if more                table)
                (setf sets (list* `(gethash ',key ,table) `',value sets))  
526       (if sets       (if sets
527           `(setf ,@sets)           `(setf ,@sets)
528           nil))))           nil))))

Removed from v.1.12  
changed lines
  Added in v.1.13

  ViewVC Help
Powered by ViewVC 1.1.5