Return to hash.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib

Annotation of 43BSD/ucb/lisp/lisplib/hash.l, revision 1.1

1.1     ! root        1: (setq rcs-hash-
        !             2:    "$Header: hash.l,v 1.2 85/03/24 11:36:16 sklower Exp $")
        !             3: 
        !             4: ;                Aug 5, 1982
        !             5: ; (c) copyright 1982, Massachusetts Institute of Technology
        !             6: ;
        !             7: ;   Hash tables are basically just fast property lists. There are much the
        !             8: ; same access functions: puthash, gethash, and remhash. The syntax is 
        !             9: ; different though. For small lists property lists are probably what you 
        !            10: ; want but when the lists start to become large hash tables become
        !            11: ; infinitely better than property lists.
        !            12: 
        !            13: ;; Current bugs:  hash-table-rehash and the equal version need to be 
        !            14: ;;               rewritten.  There is no reason to write the array twice.
        !            15: 
        !            16: ;   Note very carefully that the syntax is <puthash key value hash-table>,
        !            17: ; <gethash key hash-table>, and <remhash key hash-table>.
        !            18: 
        !            19: ;   Before hash tables are used they have to be made i.e. you first do
        !            20: ; (setq myhash (make-hash-table)) then (puthash 'name 'joe myhash).
        !            21: ; Make-hash-table takes several alternating keywords and arguments
        !            22: ; the only one of which you will probably use is :size. So 
        !            23: ; (setq otherhash (make-hash-table ':size 20)) will make otherhash a
        !            24: ; hash table of length 20. If you know what the length of the hash table
        !            25: ; will be and it is greater than about 20 it is a good idea to specify
        !            26: ; the length so that hash-table-rehash will not need to be called.
        !            27: ; This will speed up puthashing considerably especially when the hash
        !            28: ; table is very large.
        !            29: ;   Keys must be eq, equal will not work.
        !            30: 
        !            31: #+Franz (environment-maclisp)
        !            32: 
        !            33: (defstruct (hash-table (:constructor make-hash-table-internal)
        !            34:                       :named)
        !            35:   (real-hash-table (new-vector 17)) ;where entries are stored
        !            36:   (hash-table-fullness 0)      ; how many entries in table
        !            37:   (rehash-after-n-misses 4)    ; when puthashing you rehash the table
        !            38:                                ; if you miss this many times
        !            39:   (hash-table-size 17)         ; how big the vector is
        !            40:   (hash-table-rehash-size 1.5) ; factor to multiply by current size 
        !            41:                                ; to the get new size of the vector
        !            42:   (hash-table-rehash-function 'hash-table-rehash))
        !            43: 
        !            44: ;   Make-hash-table makes a hash table. The vector that all the information
        !            45: ; is stored in is made nmiss larger than the apparent size of the hash
        !            46: ; table so that if you hash to a number close to the size of the table
        !            47: ; you do not miss right off the table. So that for example if you
        !            48: ; hash to the last element of the table and miss you are not aff the table.
        !            49: 
        !            50: (defun make-hash-table (&rest options &aux (size 8) (rhf 'hash-table-rehash)
        !            51:                                           (rhs 1.5) (nmisses 4))
        !            52:   (loop for (key option) on options by #'cddr
        !            53:        do (selectq key
        !            54:                    (:size (setq size option))
        !            55:                    (:rehash-function (setq rhf option))
        !            56:                    (:rehash-size (setq rhs option))
        !            57:                    (otherwise
        !            58:                     (ferror () "~S is not a valid hash table option"
        !            59:                             key))))
        !            60:       (setq size (hash-table-good-size (* size 2)))
        !            61:       (make-hash-table-internal
        !            62:          real-hash-table (new-vector (+ size nmisses))
        !            63:         hash-table-size size
        !            64:         rehash-after-n-misses nmisses
        !            65:         hash-table-rehash-size rhs
        !            66:         hash-table-rehash-function rhf))
        !            67: 
        !            68: (defun hash-table-good-size (size)
        !            69:   (setq size (max (fix size) 17))        ;minimum size is 17
        !            70:   (or (oddp size) (setq size (1+ size))) ; make it odd
        !            71:   (do ()
        !            72:       ((and (not (zerop (\ size 3)))     ; make it a semi-prime number
        !            73:            (not (zerop (\ size 5)))
        !            74:            (not (zerop (\ size 7))))
        !            75:        size)
        !            76:       (setq size (+ size 2))))
        !            77: 
        !            78: ;; Using conses instead of putting increasing the size of the data table
        !            79: ;; by a factor of two, decreases the amount of storage required for a 
        !            80: ;; partially full hash table but can adversely affect the paging and 
        !            81: ;; caching behavior of the hash table.  Sometime, should meter this 
        !            82: ;; difference.  (A compactifying garbage collector could help.)
        !            83: 
        !            84: (defmacro make-hash-element (key value)        ; creates a hash element
        !            85:   `(cons ,key ,value))
        !            86: 
        !            87: (defmacro hash-key (element)   ; the key given a hash element
        !            88:   `(car ,element)) 
        !            89: 
        !            90: (defmacro hash-value (element) ; the value of a hash element
        !            91:   `(cdr ,element))
        !            92: 
        !            93: (defmacro si:hash-code (hash-table key)        ;hash code for key
        !            94:   `(\ (maknum ,key) (hash-table-size ,hash-table)))
        !            95: 
        !            96: ;   Gethash either returns the value associated with that key in that 
        !            97: ; hash table or nil if there is none.
        !            98: 
        !            99: (defun gethash (key hash-table &aux position-value)
        !           100:   (do ((try-position (si:hash-code hash-table key) (1+ try-position))
        !           101:        (n (rehash-after-n-misses hash-table) (1- n)) 
        !           102:        (real-hash-table (real-hash-table hash-table)))
        !           103:       ((zerop n) nil) ;it is not there so just return nil
        !           104:     (cond ((eq key
        !           105:               (hash-key (setq position-value
        !           106:                               (vref real-hash-table try-position))))
        !           107:             (return (hash-value position-value))))))
        !           108: 
        !           109: (eval-when (compile load eval)
        !           110:   (defsetf gethash (e v) `(puthash ,(cadr e) ,v ,(caddr e))))
        !           111: 
        !           112: ;   Puthash inserts a hash-element for the given key and value in the
        !           113: ; hash table that is passed to it. If the key already exists in the hash 
        !           114: ; table the value of that key is replaced by the new value. If it finds an
        !           115: ; empty space it adds a hash-element for that key and value into that 
        !           116: ; space and increments hash-table-fullness by one. If it cannot find
        !           117: ; the key or an empty space in four tries then it calls rehash on the
        !           118: ; hash table and tries again. 
        !           119: 
        !           120: (declare (localf puthash-internal))
        !           121: 
        !           122: (defun puthash (key value hash-table)
        !           123:   (puthash-internal key value hash-table nil))
        !           124: 
        !           125: (defun swaphash (key value hash-table)
        !           126:   (puthash-internal key value hash-table t))
        !           127: 
        !           128: (defun puthash-internal (key value hash-table swap?)
        !           129:   (do ((try-position (si:hash-code hash-table key) (1+ try-position))
        !           130:        (n (rehash-after-n-misses hash-table) (1- n))
        !           131:        (real-hash-table (real-hash-table hash-table)))
        !           132:       ((zerop n)  ;if cannot find a place in n tries then rehash     
        !           133:        (funcall (hash-table-rehash-function hash-table)
        !           134:                hash-table (hash-table-rehash-size hash-table))
        !           135:        (puthash key value hash-table))
        !           136:     (cond ((or (eq (hash-key (vref real-hash-table try-position))
        !           137:                   key)
        !           138:               (and (null (vref real-hash-table try-position))
        !           139:                    (setf (hash-table-fullness hash-table)
        !           140:                            (1+ (hash-table-fullness hash-table)))))
        !           141:           (return
        !           142:            (prog1 (if swap? (hash-value (vref real-hash-table try-position))
        !           143:                       value)
        !           144:                   (setf (vref real-hash-table try-position)
        !           145:                         (make-hash-element key value))))))))
        !           146: 
        !           147: ;   Remhash removes the hash-element associated with the given key from
        !           148: ; the hash table that is passed to it. If it finds the element and removes
        !           149: ; it then it returns the key. If it cannot find the element then it returns
        !           150: ; nil.
        !           151: 
        !           152: (defun remhash (key hash-table)
        !           153:   (do ((try-position (si:hash-code hash-table key) (1+ try-position))
        !           154:        (n (rehash-after-n-misses hash-table) (1- n))
        !           155:        (real-hash-table (real-hash-table hash-table)))
        !           156:       ((zerop n) nil)   ;not in the hash table return nil
        !           157:     (cond ((eq (hash-key (vref real-hash-table try-position)) key)
        !           158:           (setf (vref real-hash-table try-position) nil)
        !           159:           (return key))))) ;return the key if found and removed
        !           160: 
        !           161: ;    Hash-table-rehash first saves the contents of the current hash table
        !           162: ; in a temporary vector then puthashes the elements of this temporary vector
        !           163: ; into the original hash-table after making it larger by a factor of
        !           164: ; the variable grow.
        !           165: 
        !           166: (defun hash-table-rehash (hash-table grow)
        !           167:   (let* ((real-hash-table  (real-hash-table hash-table))
        !           168:         (nmisses (rehash-after-n-misses hash-table))
        !           169:         (new-size (+ nmisses
        !           170:                      (hash-table-good-size (times grow
        !           171:                                              (hash-table-size hash-table)))))
        !           172:         (j 0)
        !           173:         (temp-array (new-vector new-size)))
        !           174:     (do ((current-position 0 (1+ current-position))
        !           175:         (old-size (+ (hash-table-size hash-table) nmisses)))
        !           176:        ((>= current-position old-size))
        !           177:        (let ((current-hash-element (vref real-hash-table current-position)))
        !           178:          (cond ((null current-hash-element))
        !           179:                (t (setf (vref temp-array j) current-hash-element)
        !           180:                   (setq j (1+ j))))))
        !           181:     (cond ((not (= grow 1)) ;if the hash table has grown
        !           182:            (setf (real-hash-table hash-table) (new-vector new-size))
        !           183:           (setf (hash-table-fullness hash-table) 0)
        !           184:           (setf (hash-table-size hash-table) (- new-size nmisses))))
        !           185:     (do ((position 0 (1+ position))) ;add old values to new table
        !           186:        ((= position j))
        !           187:        (puthash (hash-key (vref temp-array position))
        !           188:                 (hash-value (vref temp-array position))
        !           189:                 hash-table))))
        !           190: 
        !           191: (defun si:lookhash (hash-table)
        !           192:   (let ((real-hash-table (real-hash-table hash-table)))
        !           193:     (loop for num from 0 to (1- (vsize real-hash-table))
        !           194:          collect (vref real-hash-table num))))
        !           195: 
        !           196: (defun maphash (func hash-table)
        !           197:   (let ((real-hash-table (real-hash-table hash-table)))
        !           198:     (loop for num from 0 to (1- (vsize real-hash-table))
        !           199:          with keyword and value
        !           200:          do (setq keyword (vref real-hash-table num))
        !           201:          unless (null keyword)
        !           202:          do (progn (setq value (cdr keyword)
        !           203:                          keyword (car keyword))
        !           204:                    (funcall func keyword value)))))
        !           205: 
        !           206: ;; SXHASH
        !           207: ;;  Sigh, this also comes from the LISP machine
        !           208: 
        !           209: (defun sxhash (x)
        !           210:   (cond ((symbolp x)
        !           211:         (sxhash-string (get_pname x)))
        !           212:        ((stringp x)
        !           213:         (sxhash-string x))
        !           214:        ((eq (typep x) 'fixnum)
        !           215:         (if (minusp x)
        !           216:             (logxor x #o-1777777777)
        !           217:             x))
        !           218:        ((dtpr x)
        !           219:         (do ((rot 4)
        !           220:              (hash 0)
        !           221:              (y))
        !           222:             ((atom x)
        !           223:              (if (not (null x))
        !           224:                  (setq hash (logxor (rot (sxhash x) (- rot 4)) hash)))
        !           225:              (if (minusp hash)
        !           226:                  (logxor hash #o-1777777777)
        !           227:                  hash))
        !           228:           (setq y (pop x))
        !           229:           (if (>= (setq rot (+ rot 7)) 24)
        !           230:               (setq rot (- rot 24)))
        !           231:           (setq hash (logxor (rot (cond ((symbolp y)
        !           232:                                          (sxhash-string (get_pname y)))
        !           233:                                         ((stringp y)
        !           234:                                          (sxhash-string y))
        !           235:                                         ((eq (typep y) 'fixnum)
        !           236:                                          y)
        !           237:                                         (t (sxhash y)))
        !           238:                                   rot)
        !           239:                              hash))))
        !           240:        ((bigp x)
        !           241:         (sxhash (bignum-to-list x)))
        !           242:        ((floatp x)
        !           243:         (fix x))
        !           244:        (t 0)))
        !           245: 
        !           246: (defun sxhash-string (string)
        !           247:   (do ((i 1 (1+ i))
        !           248:        (n (flatc string))
        !           249:        (hash 0))
        !           250:     ((> i n)
        !           251:      (if (minusp hash)
        !           252:         (logxor hash #o-1777777777)
        !           253:         hash))
        !           254:     (setq hash (rot (logxor (getcharn string i) #o177) 7))))
        !           255: 
        !           256: ;; Equal hash tables
        !           257: 
        !           258: ;; Notice the slots are exactly the same as in hash-table so we use the same
        !           259: ;; macros.
        !           260: 
        !           261: (defstruct (equal-hash-table (:constructor make-equal-hash-table-internal)
        !           262:                             :named)
        !           263:   (real-hash-table (new-vector 17)) ;where entries are stored
        !           264:   (hash-table-fullness 0)      ; how many entries in table
        !           265:   (rehash-after-n-misses 4)    ; when puthashing you rehash the table
        !           266:                                ; if you miss this many times
        !           267:   (hash-table-size 17)         ; how big the vector is
        !           268:   (hash-table-rehash-size 1.5) ; factor to multiply by current size 
        !           269:                                ; to the get new size of the vector
        !           270:   (hash-table-rehash-function 'equal-hash-table-rehash))
        !           271: 
        !           272: ;   Make-hash-table makes a hash table. The vector that all the information
        !           273: ; is stored in is made nmiss larger than the apparent size of the hash
        !           274: ; table so that if you hash to a number close to the size of the table
        !           275: ; you do not miss right off the table. So that for example if you
        !           276: ; hash to the last element of the table and miss you are not aff the table.
        !           277: 
        !           278: (defun make-equal-hash-table (&rest options &aux (size 8)
        !           279:                                           (rhf 'hash-table-rehash)
        !           280:                                           (rhs 1.5) (nmisses 4))
        !           281:   (loop for (key option) on options by #'cddr
        !           282:        do (selectq key
        !           283:                    (:size (setq size option))
        !           284:                    (:rehash-function (setq rhf option))
        !           285:                    (:rehash-size (setq rhs option))
        !           286:                    (otherwise
        !           287:                     (ferror () "~S is not a valid hash table option"
        !           288:                             key))))
        !           289:       (setq size (hash-table-good-size (* size 2)))
        !           290:       (make-equal-hash-table-internal
        !           291:          real-hash-table (new-vector (+ size nmisses))
        !           292:         hash-table-size size
        !           293:         rehash-after-n-misses nmisses
        !           294:         hash-table-rehash-size rhs
        !           295:         hash-table-rehash-function rhf))
        !           296: 
        !           297: ;   Gethash-equal either returns the value associated with that key in that 
        !           298: ; hash table or nil if there is none.
        !           299: 
        !           300: (defun gethash-equal (key hash-table &aux position-value)
        !           301:   (do ((try-position (remainder (sxhash key) (hash-table-size  hash-table))
        !           302:                     (1+ try-position))
        !           303:        (n (rehash-after-n-misses hash-table) (1- n)) 
        !           304:        (real-hash-table (real-hash-table hash-table)))
        !           305:       ((zerop n) nil) ;it is not there so just return nil
        !           306:       (cond ((equal key
        !           307:                    (hash-key (setq position-value
        !           308:                                    (vref real-hash-table try-position))))
        !           309:             (return (hash-value position-value))))))
        !           310: 
        !           311: (eval-when (eval compile load)
        !           312:   (defsetf gethash-equal (e v) `(puthash-equal ,(cadr e) v ,(caddr e))))
        !           313: 
        !           314: ;   Puthash inserts a hash-element for the given key and value in the
        !           315: ; hash table that is passed to it. If the key already exists in the hash 
        !           316: ; table the value of that key is replaced by the new value. If it finds an
        !           317: ; empty space it adds a hash-element for that key and value into that 
        !           318: ; space and increments hash-table-fullness by one. If it cannot find
        !           319: ; the key or an empty space in four tries then it calls rehash on the
        !           320: ; hash table and tries again. 
        !           321: 
        !           322: (declare (localf puthash-equal-internal))
        !           323: 
        !           324: (defun puthash-equal (key value hash-table)
        !           325:   (puthash-equal-internal key value hash-table nil))
        !           326: 
        !           327: (defun swaphash-equal (key value hash-table)
        !           328:   (puthash-equal-internal key value hash-table t))
        !           329: 
        !           330: (defun puthash-equal-internal (key value hash-table swap?)
        !           331:   (do ((try-position (remainder (sxhash key) (hash-table-size hash-table))
        !           332:                     (1+ try-position))
        !           333:        (n (rehash-after-n-misses hash-table) (1- n))
        !           334:        (real-hash-table (real-hash-table hash-table)))
        !           335:       ((zerop n)  ;if cannot find a place in n tries then rehash     
        !           336:        (funcall (hash-table-rehash-function hash-table)
        !           337:                hash-table (hash-table-rehash-size hash-table))
        !           338:        (puthash-equal key value hash-table))
        !           339: 
        !           340:       (cond ((or (equal (hash-key (vref real-hash-table try-position))
        !           341:                     key)
        !           342:                 (and (null (vref real-hash-table try-position))
        !           343:                      (setf (hash-table-fullness hash-table)
        !           344:                            (1+ (hash-table-fullness hash-table)))))
        !           345:             (return
        !           346:              (prog1 (if swap? (hash-value
        !           347:                                (vref real-hash-table try-position))
        !           348:                         value)
        !           349:                     (setf (vref real-hash-table try-position)
        !           350:                           (make-hash-element key value))))))))
        !           351: 
        !           352: 
        !           353: ;   Remhash removes the hash-element associated with the given key from
        !           354: ; the hash table that is passed to it. If it finds the element and removes
        !           355: ; it then it returns the key. If it cannot find the element then it returns
        !           356: ; nil.
        !           357: 
        !           358: (defun remhash-equal (key hash-table)
        !           359:   (do ((try-position (remainder (sxhash key) (hash-table-size hash-table))
        !           360:                     (1+ try-position))
        !           361:        (n (rehash-after-n-misses hash-table) (1- n))
        !           362:        (real-hash-table (real-hash-table hash-table)))
        !           363:       ((zerop n) nil)   ;not in the hash table return nil
        !           364:       (cond ((equal (hash-key (vref real-hash-table try-position)) key)
        !           365:             (setf (vref real-hash-table try-position) nil)
        !           366:             (return key))))) ;return the key if found and removed
        !           367: 
        !           368: 
        !           369: ;    Hash-table-rehash first saves the contents of the current hash table
        !           370: ; in a temporary vector then puthashes the elements of this temporary vector
        !           371: ; into the original hash-table after making it larger by a factor of
        !           372: ; the variable grow.
        !           373: 
        !           374: (defun equal-hash-table-rehash (hash-table grow)
        !           375:   (let* ((real-hash-table  (real-hash-table hash-table))
        !           376:         (nmisses (rehash-after-n-misses hash-table))
        !           377:         (new-size (+ nmisses
        !           378:                      (hash-table-good-size (times grow
        !           379:                                              (hash-table-size hash-table)))))
        !           380:         (j 0)
        !           381:         (temp-array (new-vector new-size)))
        !           382:     (do ((current-position 0 (1+ current-position))
        !           383:         (old-size (+ (hash-table-size hash-table) nmisses)))
        !           384:        ((>= current-position old-size))
        !           385:        (let ((current-hash-element (vref real-hash-table current-position)))
        !           386:          (cond ((null current-hash-element))
        !           387:                (t (setf (vref temp-array j) current-hash-element)
        !           388:                   (setq j (1+ j))))))
        !           389:     (cond ((not (= grow 1)) ;if the hash table has grown
        !           390:            (setf (real-hash-table hash-table) (new-vector new-size))
        !           391:           (setf (hash-table-fullness hash-table) 0)
        !           392:           (setf (hash-table-size hash-table) (- new-size nmisses))))
        !           393:     (do ((position 0 (1+ position))) ;add old values to new table
        !           394:        ((= position j))
        !           395:        (puthash (hash-key (vref temp-array position))
        !           396:                 (hash-value (vref temp-array position))
        !           397:                 hash-table))))
        !           398: 
        !           399: (defun maphash-equal (func hash-table)
        !           400:   (let ((real-hash-table (real-hash-table hash-table)))
        !           401:     (loop for num from 0 to (1- (vsize real-hash-table))
        !           402:          with keyword and value
        !           403:          do (setq keyword (vref real-hash-table num))
        !           404:          unless (null keyword)
        !           405:          do (progn (setq value (cdr keyword)
        !           406:                          keyword (car keyword))
        !           407:                    (funcall func keyword value)))))
        !           408: 
        !           409: (sstatus feature hash-tables)

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.