4.3BSD/usr/lib/lisp/hash.l
(setq rcs-hash-
"$Header: hash.l,v 1.2 85/03/24 11:36:16 sklower Exp $")
; Aug 5, 1982
; (c) copyright 1982, Massachusetts Institute of Technology
;
; Hash tables are basically just fast property lists. There are much the
; same access functions: puthash, gethash, and remhash. The syntax is
; different though. For small lists property lists are probably what you
; want but when the lists start to become large hash tables become
; infinitely better than property lists.
;; Current bugs: hash-table-rehash and the equal version need to be
;; rewritten. There is no reason to write the array twice.
; Note very carefully that the syntax is <puthash key value hash-table>,
; <gethash key hash-table>, and <remhash key hash-table>.
; Before hash tables are used they have to be made i.e. you first do
; (setq myhash (make-hash-table)) then (puthash 'name 'joe myhash).
; Make-hash-table takes several alternating keywords and arguments
; the only one of which you will probably use is :size. So
; (setq otherhash (make-hash-table ':size 20)) will make otherhash a
; hash table of length 20. If you know what the length of the hash table
; will be and it is greater than about 20 it is a good idea to specify
; the length so that hash-table-rehash will not need to be called.
; This will speed up puthashing considerably especially when the hash
; table is very large.
; Keys must be eq, equal will not work.
#+Franz (environment-maclisp)
(defstruct (hash-table (:constructor make-hash-table-internal)
:named)
(real-hash-table (new-vector 17)) ;where entries are stored
(hash-table-fullness 0) ; how many entries in table
(rehash-after-n-misses 4) ; when puthashing you rehash the table
; if you miss this many times
(hash-table-size 17) ; how big the vector is
(hash-table-rehash-size 1.5) ; factor to multiply by current size
; to the get new size of the vector
(hash-table-rehash-function 'hash-table-rehash))
; Make-hash-table makes a hash table. The vector that all the information
; is stored in is made nmiss larger than the apparent size of the hash
; table so that if you hash to a number close to the size of the table
; you do not miss right off the table. So that for example if you
; hash to the last element of the table and miss you are not aff the table.
(defun make-hash-table (&rest options &aux (size 8) (rhf 'hash-table-rehash)
(rhs 1.5) (nmisses 4))
(loop for (key option) on options by #'cddr
do (selectq key
(:size (setq size option))
(:rehash-function (setq rhf option))
(:rehash-size (setq rhs option))
(otherwise
(ferror () "~S is not a valid hash table option"
key))))
(setq size (hash-table-good-size (* size 2)))
(make-hash-table-internal
real-hash-table (new-vector (+ size nmisses))
hash-table-size size
rehash-after-n-misses nmisses
hash-table-rehash-size rhs
hash-table-rehash-function rhf))
(defun hash-table-good-size (size)
(setq size (max (fix size) 17)) ;minimum size is 17
(or (oddp size) (setq size (1+ size))) ; make it odd
(do ()
((and (not (zerop (\ size 3))) ; make it a semi-prime number
(not (zerop (\ size 5)))
(not (zerop (\ size 7))))
size)
(setq size (+ size 2))))
;; Using conses instead of putting increasing the size of the data table
;; by a factor of two, decreases the amount of storage required for a
;; partially full hash table but can adversely affect the paging and
;; caching behavior of the hash table. Sometime, should meter this
;; difference. (A compactifying garbage collector could help.)
(defmacro make-hash-element (key value) ; creates a hash element
`(cons ,key ,value))
(defmacro hash-key (element) ; the key given a hash element
`(car ,element))
(defmacro hash-value (element) ; the value of a hash element
`(cdr ,element))
(defmacro si:hash-code (hash-table key) ;hash code for key
`(\ (maknum ,key) (hash-table-size ,hash-table)))
; Gethash either returns the value associated with that key in that
; hash table or nil if there is none.
(defun gethash (key hash-table &aux position-value)
(do ((try-position (si:hash-code hash-table key) (1+ try-position))
(n (rehash-after-n-misses hash-table) (1- n))
(real-hash-table (real-hash-table hash-table)))
((zerop n) nil) ;it is not there so just return nil
(cond ((eq key
(hash-key (setq position-value
(vref real-hash-table try-position))))
(return (hash-value position-value))))))
(eval-when (compile load eval)
(defsetf gethash (e v) `(puthash ,(cadr e) ,v ,(caddr e))))
; Puthash inserts a hash-element for the given key and value in the
; hash table that is passed to it. If the key already exists in the hash
; table the value of that key is replaced by the new value. If it finds an
; empty space it adds a hash-element for that key and value into that
; space and increments hash-table-fullness by one. If it cannot find
; the key or an empty space in four tries then it calls rehash on the
; hash table and tries again.
(declare (localf puthash-internal))
(defun puthash (key value hash-table)
(puthash-internal key value hash-table nil))
(defun swaphash (key value hash-table)
(puthash-internal key value hash-table t))
(defun puthash-internal (key value hash-table swap?)
(do ((try-position (si:hash-code hash-table key) (1+ try-position))
(n (rehash-after-n-misses hash-table) (1- n))
(real-hash-table (real-hash-table hash-table)))
((zerop n) ;if cannot find a place in n tries then rehash
(funcall (hash-table-rehash-function hash-table)
hash-table (hash-table-rehash-size hash-table))
(puthash key value hash-table))
(cond ((or (eq (hash-key (vref real-hash-table try-position))
key)
(and (null (vref real-hash-table try-position))
(setf (hash-table-fullness hash-table)
(1+ (hash-table-fullness hash-table)))))
(return
(prog1 (if swap? (hash-value (vref real-hash-table try-position))
value)
(setf (vref real-hash-table try-position)
(make-hash-element key value))))))))
; Remhash removes the hash-element associated with the given key from
; the hash table that is passed to it. If it finds the element and removes
; it then it returns the key. If it cannot find the element then it returns
; nil.
(defun remhash (key hash-table)
(do ((try-position (si:hash-code hash-table key) (1+ try-position))
(n (rehash-after-n-misses hash-table) (1- n))
(real-hash-table (real-hash-table hash-table)))
((zerop n) nil) ;not in the hash table return nil
(cond ((eq (hash-key (vref real-hash-table try-position)) key)
(setf (vref real-hash-table try-position) nil)
(return key))))) ;return the key if found and removed
; Hash-table-rehash first saves the contents of the current hash table
; in a temporary vector then puthashes the elements of this temporary vector
; into the original hash-table after making it larger by a factor of
; the variable grow.
(defun hash-table-rehash (hash-table grow)
(let* ((real-hash-table (real-hash-table hash-table))
(nmisses (rehash-after-n-misses hash-table))
(new-size (+ nmisses
(hash-table-good-size (times grow
(hash-table-size hash-table)))))
(j 0)
(temp-array (new-vector new-size)))
(do ((current-position 0 (1+ current-position))
(old-size (+ (hash-table-size hash-table) nmisses)))
((>= current-position old-size))
(let ((current-hash-element (vref real-hash-table current-position)))
(cond ((null current-hash-element))
(t (setf (vref temp-array j) current-hash-element)
(setq j (1+ j))))))
(cond ((not (= grow 1)) ;if the hash table has grown
(setf (real-hash-table hash-table) (new-vector new-size))
(setf (hash-table-fullness hash-table) 0)
(setf (hash-table-size hash-table) (- new-size nmisses))))
(do ((position 0 (1+ position))) ;add old values to new table
((= position j))
(puthash (hash-key (vref temp-array position))
(hash-value (vref temp-array position))
hash-table))))
(defun si:lookhash (hash-table)
(let ((real-hash-table (real-hash-table hash-table)))
(loop for num from 0 to (1- (vsize real-hash-table))
collect (vref real-hash-table num))))
(defun maphash (func hash-table)
(let ((real-hash-table (real-hash-table hash-table)))
(loop for num from 0 to (1- (vsize real-hash-table))
with keyword and value
do (setq keyword (vref real-hash-table num))
unless (null keyword)
do (progn (setq value (cdr keyword)
keyword (car keyword))
(funcall func keyword value)))))
;; SXHASH
;; Sigh, this also comes from the LISP machine
(defun sxhash (x)
(cond ((symbolp x)
(sxhash-string (get_pname x)))
((stringp x)
(sxhash-string x))
((eq (typep x) 'fixnum)
(if (minusp x)
(logxor x #o-1777777777)
x))
((dtpr x)
(do ((rot 4)
(hash 0)
(y))
((atom x)
(if (not (null x))
(setq hash (logxor (rot (sxhash x) (- rot 4)) hash)))
(if (minusp hash)
(logxor hash #o-1777777777)
hash))
(setq y (pop x))
(if (>= (setq rot (+ rot 7)) 24)
(setq rot (- rot 24)))
(setq hash (logxor (rot (cond ((symbolp y)
(sxhash-string (get_pname y)))
((stringp y)
(sxhash-string y))
((eq (typep y) 'fixnum)
y)
(t (sxhash y)))
rot)
hash))))
((bigp x)
(sxhash (bignum-to-list x)))
((floatp x)
(fix x))
(t 0)))
(defun sxhash-string (string)
(do ((i 1 (1+ i))
(n (flatc string))
(hash 0))
((> i n)
(if (minusp hash)
(logxor hash #o-1777777777)
hash))
(setq hash (rot (logxor (getcharn string i) #o177) 7))))
;; Equal hash tables
;; Notice the slots are exactly the same as in hash-table so we use the same
;; macros.
(defstruct (equal-hash-table (:constructor make-equal-hash-table-internal)
:named)
(real-hash-table (new-vector 17)) ;where entries are stored
(hash-table-fullness 0) ; how many entries in table
(rehash-after-n-misses 4) ; when puthashing you rehash the table
; if you miss this many times
(hash-table-size 17) ; how big the vector is
(hash-table-rehash-size 1.5) ; factor to multiply by current size
; to the get new size of the vector
(hash-table-rehash-function 'equal-hash-table-rehash))
; Make-hash-table makes a hash table. The vector that all the information
; is stored in is made nmiss larger than the apparent size of the hash
; table so that if you hash to a number close to the size of the table
; you do not miss right off the table. So that for example if you
; hash to the last element of the table and miss you are not aff the table.
(defun make-equal-hash-table (&rest options &aux (size 8)
(rhf 'hash-table-rehash)
(rhs 1.5) (nmisses 4))
(loop for (key option) on options by #'cddr
do (selectq key
(:size (setq size option))
(:rehash-function (setq rhf option))
(:rehash-size (setq rhs option))
(otherwise
(ferror () "~S is not a valid hash table option"
key))))
(setq size (hash-table-good-size (* size 2)))
(make-equal-hash-table-internal
real-hash-table (new-vector (+ size nmisses))
hash-table-size size
rehash-after-n-misses nmisses
hash-table-rehash-size rhs
hash-table-rehash-function rhf))
; Gethash-equal either returns the value associated with that key in that
; hash table or nil if there is none.
(defun gethash-equal (key hash-table &aux position-value)
(do ((try-position (remainder (sxhash key) (hash-table-size hash-table))
(1+ try-position))
(n (rehash-after-n-misses hash-table) (1- n))
(real-hash-table (real-hash-table hash-table)))
((zerop n) nil) ;it is not there so just return nil
(cond ((equal key
(hash-key (setq position-value
(vref real-hash-table try-position))))
(return (hash-value position-value))))))
(eval-when (eval compile load)
(defsetf gethash-equal (e v) `(puthash-equal ,(cadr e) v ,(caddr e))))
; Puthash inserts a hash-element for the given key and value in the
; hash table that is passed to it. If the key already exists in the hash
; table the value of that key is replaced by the new value. If it finds an
; empty space it adds a hash-element for that key and value into that
; space and increments hash-table-fullness by one. If it cannot find
; the key or an empty space in four tries then it calls rehash on the
; hash table and tries again.
(declare (localf puthash-equal-internal))
(defun puthash-equal (key value hash-table)
(puthash-equal-internal key value hash-table nil))
(defun swaphash-equal (key value hash-table)
(puthash-equal-internal key value hash-table t))
(defun puthash-equal-internal (key value hash-table swap?)
(do ((try-position (remainder (sxhash key) (hash-table-size hash-table))
(1+ try-position))
(n (rehash-after-n-misses hash-table) (1- n))
(real-hash-table (real-hash-table hash-table)))
((zerop n) ;if cannot find a place in n tries then rehash
(funcall (hash-table-rehash-function hash-table)
hash-table (hash-table-rehash-size hash-table))
(puthash-equal key value hash-table))
(cond ((or (equal (hash-key (vref real-hash-table try-position))
key)
(and (null (vref real-hash-table try-position))
(setf (hash-table-fullness hash-table)
(1+ (hash-table-fullness hash-table)))))
(return
(prog1 (if swap? (hash-value
(vref real-hash-table try-position))
value)
(setf (vref real-hash-table try-position)
(make-hash-element key value))))))))
; Remhash removes the hash-element associated with the given key from
; the hash table that is passed to it. If it finds the element and removes
; it then it returns the key. If it cannot find the element then it returns
; nil.
(defun remhash-equal (key hash-table)
(do ((try-position (remainder (sxhash key) (hash-table-size hash-table))
(1+ try-position))
(n (rehash-after-n-misses hash-table) (1- n))
(real-hash-table (real-hash-table hash-table)))
((zerop n) nil) ;not in the hash table return nil
(cond ((equal (hash-key (vref real-hash-table try-position)) key)
(setf (vref real-hash-table try-position) nil)
(return key))))) ;return the key if found and removed
; Hash-table-rehash first saves the contents of the current hash table
; in a temporary vector then puthashes the elements of this temporary vector
; into the original hash-table after making it larger by a factor of
; the variable grow.
(defun equal-hash-table-rehash (hash-table grow)
(let* ((real-hash-table (real-hash-table hash-table))
(nmisses (rehash-after-n-misses hash-table))
(new-size (+ nmisses
(hash-table-good-size (times grow
(hash-table-size hash-table)))))
(j 0)
(temp-array (new-vector new-size)))
(do ((current-position 0 (1+ current-position))
(old-size (+ (hash-table-size hash-table) nmisses)))
((>= current-position old-size))
(let ((current-hash-element (vref real-hash-table current-position)))
(cond ((null current-hash-element))
(t (setf (vref temp-array j) current-hash-element)
(setq j (1+ j))))))
(cond ((not (= grow 1)) ;if the hash table has grown
(setf (real-hash-table hash-table) (new-vector new-size))
(setf (hash-table-fullness hash-table) 0)
(setf (hash-table-size hash-table) (- new-size nmisses))))
(do ((position 0 (1+ position))) ;add old values to new table
((= position j))
(puthash (hash-key (vref temp-array position))
(hash-value (vref temp-array position))
hash-table))))
(defun maphash-equal (func hash-table)
(let ((real-hash-table (real-hash-table hash-table)))
(loop for num from 0 to (1- (vsize real-hash-table))
with keyword and value
do (setq keyword (vref real-hash-table num))
unless (null keyword)
do (progn (setq value (cdr keyword)
keyword (car keyword))
(funcall func keyword value)))))
(sstatus feature hash-tables)