"$Header: /usr/lib/lisp/hash.l,v 1.1 83/01/29 18:37:46 jkf Exp $")
; (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
; Keys must be eq, equal will not work.
#+Franz (environment-maclisp)
(defstruct (hash-table (:constructor make-hash-table-internal)
(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)
(loop for (key option) on options by #'cddr
(:size (setq size option))
(:rehash-function (setq rhf option))
(:rehash-size (setq rhs option))
(ferror () "~S is not a valid hash table option"
(setq size (hash-table-good-size (* size 2)))
(make-hash-table-internal
real-hash-table (new-vector (+ size nmisses))
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
((and (not (zerop (\ size 3))) ; make it a semi-prime number
(not (zerop (\ size 7))))
;; 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
(defmacro hash-key (element) ; the key given a hash element
(defmacro hash-value (element) ; the value of a hash 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
(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))
(and (null (vref real-hash-table try-position))
(setf (hash-table-fullness hash-table)
(1+ (hash-table-fullness hash-table)))))
(prog1 (if swap? (hash-value (vref real-hash-table try-position))
(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
(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
(defun hash-table-rehash (hash-table grow)
(let* ((real-hash-table (real-hash-table hash-table))
(nmisses (rehash-after-n-misses hash-table))
(hash-table-good-size (times grow
(hash-table-size hash-table)))))
(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)
(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
(puthash (hash-key (vref temp-array position))
(hash-value (vref temp-array position))
(defun si:lookhash (hash-table)
(let ((real-hash-table (real-hash-table hash-table)))
(loop for num from 0 to (1- (getlength 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- (getlength real-hash-table))
do (setq keyword (vref real-hash-table num))
do (progn (setq value (cdr keyword)
(funcall func keyword value)))))
;; Sigh, this also comes from the LISP machine
(sxhash-string (get_pname x)))
(setq hash (logxor (rot (sxhash x) (- rot 4)) hash)))
(logxor hash #o-1777777777)
(if (>= (setq rot (+ rot 7)) 24)
(setq hash (logxor (rot (cond ((symbolp y)
(sxhash-string (get_pname y)))
(sxhash (bignum-to-list x)))
(defun sxhash-string (string)
(logxor hash #o-1777777777)
(setq hash (rot (logxor (getcharn string i) #o177) 7))))
;; Notice the slots are exactly the same as in hash-table so we use the same
(defstruct (equal-hash-table (:constructor make-equal-hash-table-internal)
(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)
(loop for (key option) on options by #'cddr
(:size (setq size option))
(:rehash-function (setq rhf option))
(:rehash-size (setq rhs option))
(ferror () "~S is not a valid hash table option"
(setq size (hash-table-good-size (* size 2)))
(make-equal-hash-table-internal
real-hash-table (new-vector (+ size nmisses))
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))
(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
(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))
(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))
(and (null (vref real-hash-table try-position))
(setf (hash-table-fullness hash-table)
(1+ (hash-table-fullness hash-table)))))
(prog1 (if swap? (hash-value
(vref real-hash-table try-position))
(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
(defun remhash-equal (key hash-table)
(do ((try-position (remainder (sxhash key) (hash-table-size hash-table))
(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
(defun equal-hash-table-rehash (hash-table grow)
(let* ((real-hash-table (real-hash-table hash-table))
(nmisses (rehash-after-n-misses hash-table))
(hash-table-good-size (times grow
(hash-table-size hash-table)))))
(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)
(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
(puthash (hash-key (vref temp-array position))
(hash-value (vref temp-array position))
(defun maphash-equal (func hash-table)
(let ((real-hash-table (real-hash-table hash-table)))
(loop for num from 0 to (1- (getlength real-hash-table))
do (setq keyword (vref real-hash-table num))
do (progn (setq value (cdr keyword)
(funcall func keyword value)))))
(sstatus feature hash-tables)