home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / hash.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  16.8 KB  |  526 lines
  1. ;;; -*- Log: code.log; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: hash.lisp,v 1.12 92/04/23 14:11:06 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Hashing and hash table functions for Spice Lisp.
  15. ;;; Written by Skef Wholey.
  16. ;;;
  17. (in-package 'lisp)
  18. (export '(hash-table hash-table-p make-hash-table
  19.       gethash remhash maphash clrhash
  20.       hash-table-count sxhash
  21.       with-hash-table-iterator))
  22.  
  23. ;;; Vector subtype codes.
  24.  
  25. (defconstant valid-hashing 2)
  26. (defconstant must-rehash 3)
  27.  
  28.  
  29. ;;; What a hash-table is:
  30.  
  31. (defstruct (hash-table (:constructor make-hash-table-structure)
  32.                (:conc-name hash-table-)
  33.                (:print-function %print-hash-table)
  34.                (:make-load-form-fun make-hash-table-load-form))
  35.   "Structure used to implement hash tables."
  36.   (kind 'eq)
  37.   (size 65 :type fixnum)
  38.   (rehash-size 101)                ; might be a float
  39.   (rehash-threshold 57 :type fixnum)
  40.   (number-entries 0 :type fixnum)
  41.   (table (required-argument) :type simple-vector))
  42.  
  43. ;;; A hash-table-table is a vector of association lists.  When an
  44. ;;; entry is made in a hash table, a pair of (key . value) is consed onto
  45. ;;; the element in the vector arrived at by hashing.
  46.  
  47. ;;; How to print one:
  48.  
  49. (defun %print-hash-table (structure stream depth)
  50.   (declare (ignore depth))
  51.   (format stream "#<~A Hash Table {~X}>"
  52.       (symbol-name (hash-table-kind structure))
  53.       (system:%primitive make-fixnum structure)))
  54.  
  55.  
  56.  
  57. ;;; Hashing functions for the three kinds of hash tables:
  58.  
  59. (eval-when (compile)
  60.  
  61. (defmacro eq-hash (object)
  62.   "Gives us a hashing of an object such that (eq a b) implies
  63.    (= (eq-hash a) (eq-hash b))"
  64.   `(truly-the (unsigned-byte 24) (%primitive make-fixnum ,object)))
  65.  
  66. (defmacro eql-hash (object)
  67.   "Gives us a hashing of an object such that (eql a b) implies
  68.    (= (eql-hash a) (eql-hash b))"
  69.   `(if (numberp ,object)
  70.        (logand (truncate ,object) most-positive-fixnum)
  71.        (truly-the fixnum (%primitive make-fixnum ,object))))
  72.  
  73. (defmacro equal-hash (object)
  74.   "Gives us a hashing of an object such that (equal a b) implies
  75.    (= (equal-hash a) (equal-hash b))"
  76.   `(sxhash ,object))
  77.  
  78. )
  79.  
  80. ;;; Rehashing functions:
  81.  
  82. (defun almost-primify (num)
  83.   (declare (fixnum num))
  84.   "Almost-Primify returns an almost prime number greater than or equal
  85.    to NUM."
  86.   (if (= (rem num 2) 0)
  87.       (setq num (+ 1 num)))
  88.   (if (= (rem num 3) 0)
  89.       (setq num (+ 2 num)))
  90.   (if (= (rem num 7) 0)
  91.       (setq num (+ 4 num)))
  92.   num)
  93.  
  94. (eval-when (compile)
  95.  
  96. (defmacro grow-size (table)
  97.   "Returns a fixnum for the next size of a growing hash-table."
  98.   `(let ((rehash-size (hash-table-rehash-size ,table)))
  99.      (if (floatp rehash-size)
  100.      (ceiling (* rehash-size (hash-table-size ,table)))
  101.      (+ rehash-size (hash-table-size ,table)))))
  102.  
  103. (defmacro grow-rehash-threshold (table new-length)
  104.   "Returns the next rehash threshold for the table."
  105.   table
  106.   `,new-length
  107. ;  `(ceiling (* (hash-table-rehash-threshold ,table)
  108. ;           (/ ,new-length (hash-table-size ,table))))
  109.   )
  110.  
  111. (defmacro hash-set (vector key value length hashing-function)
  112.   "Used for rehashing.  Enters the value for the key into the vector
  113.    by hashing.  Never grows the vector.  Assumes the key is not yet
  114.    entered."
  115.   `(let ((index (rem (the fixnum (funcall ,hashing-function ,key))
  116.              (the fixnum ,length))))
  117.      (declare (fixnum index))
  118.      (setf (aref (the simple-vector ,vector) index)
  119.        (cons (cons ,key ,value)
  120.          (aref (the simple-vector ,vector) index)))))
  121.  
  122. )
  123.  
  124. (defun rehash (structure hash-vector new-length)
  125.   (declare (simple-vector hash-vector))
  126.   (declare (fixnum new-length))
  127.   "Rehashes a hash table and replaces the TABLE entry in the structure if
  128.    someone hasn't done so already.  New vector is of NEW-LENGTH."
  129.   (do ((new-vector (make-array new-length :initial-element nil))
  130.        (i 0 (1+ i))
  131.        (size (hash-table-size structure))
  132.        (hashing-function (case (hash-table-kind structure)
  133.                (eq #'(lambda (x) (eq-hash x)))
  134.                (eql #'(lambda (x) (eql-hash x)))
  135.                (equal #'(lambda (x) (equal-hash x))))))
  136.       ((= i size)
  137.        (cond ((eq hash-vector (hash-table-table structure))
  138.           (cond ((> new-length size)
  139.              (setf (hash-table-table structure) new-vector)
  140.              (setf (hash-table-rehash-threshold structure)
  141.                (grow-rehash-threshold structure new-length))
  142.              (setf (hash-table-size structure) new-length))
  143.             (t
  144.              (setf (hash-table-table structure) new-vector)))
  145.           (if (not (eq (hash-table-kind structure) 'equal))
  146.           (%primitive set-vector-subtype new-vector
  147.                   valid-hashing)))))
  148.     (declare (fixnum i size))
  149.     (do ((bucket (aref hash-vector i) (cdr bucket)))
  150.     ((null bucket))
  151.       (hash-set new-vector (caar bucket) (cdar bucket) new-length
  152.         hashing-function))
  153.     (setf (aref hash-vector i) nil)))
  154.  
  155. ;;; Macros for Gethash, %Puthash, and Remhash:
  156.  
  157. (eval-when (compile)
  158.  
  159. ;;; Hashop dispatches on the kind of hash table we've got, rehashes if
  160. ;;; necessary, and binds Vector to the hash vector, Index to the index
  161. ;;; into that vector that the Key points to, and Size to the size of the
  162. ;;; hash vector.  Since Equal hash tables only need to be maybe rehashed
  163. ;;; sometimes, one can tell it if it's one of those times with the
  164. ;;; Equal-Needs-To-Rehash-P argument.
  165.  
  166. (defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body)
  167.   `(let* ((vector (hash-table-table hash-table))
  168.       (size (length vector)))
  169.      (declare (simple-vector vector) (fixnum size)
  170.           (inline assoc))
  171.      (case (hash-table-kind hash-table)
  172.        (equal
  173.     ,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed)))
  174.     (let ((index (rem (the fixnum (equal-hash key)) size)))
  175.       (declare (fixnum index))
  176.       ,equal-body))
  177.        (eq
  178.     (without-gcing
  179.       (eq-rehash-if-needed)
  180.       (let ((index (rem (the fixnum (eq-hash key)) size)))
  181.         (declare (fixnum index))
  182.         ,eq-body)))
  183.        (eql
  184.     (without-gcing
  185.       (eq-rehash-if-needed)
  186.       (let ((index (rem (the fixnum (eql-hash key)) size)))
  187.         (declare (fixnum index))
  188.         ,eql-body))))))
  189.  
  190. (defmacro eq-rehash-if-needed ()
  191.   `(let ((subtype (truly-the (unsigned-byte 24)
  192.                  (%primitive get-vector-subtype vector))))
  193.      (declare (type (unsigned-byte 24) subtype))
  194.      (cond ((/= subtype valid-hashing)
  195.         (rehash hash-table vector size)
  196.         (setq vector (hash-table-table hash-table)))
  197.        ((> (hash-table-number-entries hash-table)
  198.            (hash-table-rehash-threshold hash-table))
  199.         (rehash hash-table vector (grow-size hash-table))
  200.         (setq vector (hash-table-table hash-table))
  201.         (setq size (length vector))))))
  202.  
  203. (defmacro equal-rehash-if-needed ()
  204.   `(cond ((> (hash-table-number-entries hash-table)
  205.          (hash-table-rehash-threshold hash-table))
  206.       (rehash hash-table vector (grow-size hash-table))
  207.       (setq vector (hash-table-table hash-table))
  208.       (setq size (length vector)))))
  209.  
  210. (defmacro rehash-if-needed ()
  211.   `(let ((subtype (truly-the (unsigned-byte 24)
  212.                  (%primitive get-vector-subtype vector)))
  213.      (size (length vector)))
  214.      (declare (type (unsigned-byte 24) subtype)
  215.           (fixnum size))
  216.      (cond ((and (not (eq (hash-table-kind hash-table) 'equal))
  217.          (/= subtype valid-hashing))
  218.         (rehash hash-table vector size)
  219.         (setq vector (hash-table-table hash-table))
  220.         (setq size (length vector)))
  221.        ((> (hash-table-number-entries hash-table)
  222.            (hash-table-rehash-threshold hash-table))
  223.         (rehash hash-table vector (grow-size hash-table))
  224.         (setq vector (hash-table-table hash-table))
  225.         (setq size (length vector))))))
  226.  
  227. )
  228.  
  229. ;;; Making hash tables:
  230.  
  231. (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)
  232.                  (rehash-threshold size))
  233.   "Creates and returns a hash table.  See manual for details."
  234.   (declare (type (or function (member eq eql equal)) test)
  235.        (type index size rehash-size)
  236.        (type (or (float 0.0 1.0) index) rehash-threshold))
  237.   (let* ((test (cond ((or (eq test #'eq) (eq test 'eq)) 'eq)
  238.              ((or (eq test #'eql) (eq test 'eql)) 'eql)
  239.              ((or (eq test #'equal) (eq test 'equal)) 'equal)
  240.              (t
  241.               (error "~S is an illegal :Test for hash tables." test))))
  242.      (size (if (<= size 37) 37 (almost-primify size)))
  243.      (rehash-threshold
  244.       (cond ((and (fixnump rehash-threshold)
  245.               (<= 0 rehash-threshold size))
  246.          rehash-threshold)
  247.         ((and (floatp rehash-threshold)
  248.               (<= 0.0 rehash-threshold 1.0))
  249.          (ceiling (* rehash-threshold size)))
  250.         (t
  251.          (error "Invalid rehash-threshold: ~S.~%Must be either a float ~
  252.              between 0.0 and 1.0 ~%or an integer between 0 and ~D."
  253.             rehash-threshold
  254.             size))))
  255.      (table (make-array size :initial-element nil)))
  256.     (make-hash-table-structure :size size
  257.                    :rehash-size rehash-size
  258.                    :rehash-threshold rehash-threshold
  259.                    :table
  260.                    (if (eq test 'equal)
  261.                    table
  262.                    (%primitive set-vector-subtype
  263.                            table
  264.                            valid-hashing))
  265.                    :kind test)))
  266.  
  267. ;;; Manipulating hash tables:
  268.  
  269. (defun gethash (key hash-table &optional default)
  270.   "Finds the entry in Hash-Table whose key is Key and returns the associated
  271.    value and T as multiple values, or returns Default and Nil if there is no
  272.    such entry."
  273.   (macrolet ((lookup (test)
  274.            `(let ((cons (assoc key (aref vector index) :test #',test)))
  275.           (declare (list cons))
  276.           (if cons
  277.               (values (cdr cons) t)
  278.               (values default nil)))))
  279.     (hashop nil
  280.       (lookup eq)
  281.       (lookup eql)
  282.       (lookup equal))))
  283.  
  284. (defun %puthash (key hash-table value)
  285.   "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
  286.    is an entry for KEY, replace it.  Returns VALUE."
  287.   (macrolet ((store (test)
  288.            `(let ((cons (assoc key (aref vector index) :test #',test)))
  289.           (declare (list cons))
  290.           (cond (cons (setf (cdr cons) value))
  291.             (t
  292.              (push (cons key value) (aref vector index))
  293.              (incf (hash-table-number-entries hash-table))
  294.              value)))))
  295.     (hashop t
  296.       (store eq)
  297.       (store eql)
  298.       (store equal))))
  299.  
  300. (defun remhash (key hash-table)
  301.   "Remove any entry for KEY in HASH-TABLE.  Returns T if such an entry
  302.    existed; () otherwise."
  303.   (hashop nil
  304.    (let ((bucket (aref vector index)))        ; EQ case
  305.      (cond ((and bucket (eq (caar bucket) key))
  306.         (pop (aref vector index))
  307.         (decf (hash-table-number-entries hash-table))
  308.         t)
  309.        (t
  310.         (do ((last bucket bucket)
  311.          (bucket (cdr bucket) (cdr bucket)))
  312.         ((null bucket) ())
  313.           (when (eq (caar bucket) key)
  314.         (rplacd last (cdr bucket))
  315.         (decf (hash-table-number-entries hash-table))
  316.         (return t))))))
  317.    (let ((bucket (aref vector index)))        ; EQL case
  318.      (cond ((and bucket (eql (caar bucket) key))
  319.         (pop (aref vector index))
  320.         (decf (hash-table-number-entries hash-table))
  321.         t)
  322.        (t
  323.         (do ((last bucket bucket)
  324.          (bucket (cdr bucket) (cdr bucket)))
  325.         ((null bucket) ())
  326.           (when (eql (caar bucket) key)
  327.         (rplacd last (cdr bucket))
  328.         (decf (hash-table-number-entries hash-table))
  329.         (return t))))))
  330.    (let ((bucket (aref vector index)))        ; EQUAL case
  331.      (cond ((and bucket (equal (caar bucket) key))
  332.         (pop (aref vector index))
  333.         (decf (hash-table-number-entries hash-table))
  334.         t)
  335.        (t
  336.         (do ((last bucket bucket)
  337.          (bucket (cdr bucket) (cdr bucket)))
  338.         ((null bucket) ())
  339.           (when (equal (caar bucket) key)
  340.         (rplacd last (cdr bucket))
  341.         (decf (hash-table-number-entries hash-table))
  342.         (return t))))))))
  343.  
  344. (defun maphash (map-function hash-table)
  345.   "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
  346.   of the entry; returns NIL."
  347.   (let ((vector (hash-table-table hash-table)))
  348.     (declare (simple-vector vector))
  349.     (rehash-if-needed)
  350.     (do ((i 0 (1+ i))
  351.      (size (hash-table-size hash-table)))
  352.     ((= i size))
  353.       (declare (fixnum i size))
  354.       (do ((bucket (aref vector i) (cdr bucket)))
  355.       ((null bucket))
  356.     
  357.     (funcall map-function (caar bucket) (cdar bucket))))))
  358.  
  359. (defun clrhash (hash-table)
  360.   "Removes all entries of HASH-TABLE and returns the hash table itself."
  361.   (let ((vector (hash-table-table hash-table)))
  362.     (declare (simple-vector vector))
  363.     (setf (hash-table-number-entries hash-table) 0)
  364.     (do ((i 0 (1+ i))
  365.      (size (hash-table-size hash-table)))
  366.     ((= i size) hash-table)
  367.       (declare (fixnum i size))
  368.       (setf (aref vector i) nil))))
  369.  
  370. (defun hash-table-count (hash-table)
  371.   "Returns the number of entries in the given Hash-Table."
  372.   (hash-table-number-entries hash-table))
  373.  
  374. ;;; Primitive Hash Function
  375.  
  376. ;;; The maximum length and depth to which we hash lists.
  377. (defconstant sxhash-max-len 7)
  378. (defconstant sxhash-max-depth 3)
  379.  
  380. (eval-when (compile eval)
  381.  
  382. (defconstant sxhash-bits-byte (byte 23 0))
  383. (defconstant sxmash-total-bits 26)
  384. (defconstant sxmash-rotate-bits 7)
  385.  
  386. (defmacro sxmash (place with)
  387.   (let ((n-with (gensym)))
  388.     `(let ((,n-with ,with))
  389.        (declare (fixnum ,n-with))
  390.        (setf ,place
  391.          (logxor (ash ,n-with ,(- sxmash-rotate-bits sxmash-total-bits))
  392.              (ash (logand ,n-with
  393.                   ,(1- (ash 1
  394.                         (- sxmash-total-bits
  395.                            sxmash-rotate-bits))))
  396.               ,sxmash-rotate-bits)
  397.              (the fixnum ,place))))))
  398.  
  399. (defmacro sxhash-simple-string (sequence)
  400.   `(%sxhash-simple-string ,sequence))
  401.  
  402. (defmacro sxhash-string (sequence)
  403.   (let ((data (gensym))
  404.     (start (gensym))
  405.     (end (gensym)))
  406.     `(with-array-data ((,data ,sequence)
  407.                (,start)
  408.                (,end))
  409.        (if (zerop ,start)
  410.        (%sxhash-simple-substring ,data ,end)
  411.        (sxhash-simple-string (coerce (the string ,sequence)
  412.                      'simple-string))))))
  413.  
  414. (defmacro sxhash-list (sequence depth)
  415.   `(if (= ,depth sxhash-max-depth)
  416.        0
  417.        (do ((sequence ,sequence (cdr (the list sequence)))
  418.         (index 0 (1+ index))
  419.         (hash 2))
  420.        ((or (atom sequence) (= index sxhash-max-len)) hash)
  421.      (declare (fixnum hash index))
  422.      (sxmash hash (internal-sxhash (car sequence) (1+ ,depth))))))
  423.  
  424.  
  425. ); eval-when (compile eval)
  426.  
  427.  
  428. (defun sxhash (s-expr)
  429.   "Computes a hash code for S-EXPR and returns it as an integer."
  430.   (internal-sxhash s-expr 0))
  431.  
  432.  
  433. (defun internal-sxhash (s-expr depth)
  434.   (typecase s-expr
  435.     ;; The pointers and immediate types.
  436.     (list (sxhash-list s-expr depth))
  437.     (fixnum
  438.      (ldb sxhash-bits-byte s-expr))
  439.     (structure
  440.      (internal-sxhash (type-of s-expr) depth))
  441.     ;; Other-pointer types.
  442.     (simple-string (sxhash-simple-string s-expr))
  443.     (symbol (sxhash-simple-string (symbol-name s-expr)))
  444.     (number
  445.      (etypecase s-expr
  446.        (integer (ldb sxhash-bits-byte s-expr))
  447.        (single-float
  448.     (let ((bits (single-float-bits s-expr)))
  449.       (ldb sxhash-bits-byte
  450.            (logxor (ash bits (- sxmash-rotate-bits))
  451.                bits))))
  452.        (double-float
  453.     (let* ((val s-expr)
  454.            (lo (double-float-low-bits val))
  455.            (hi (double-float-high-bits val)))
  456.       (ldb sxhash-bits-byte
  457.            (logxor (ash lo (- sxmash-rotate-bits))
  458.                (ash hi (- sxmash-rotate-bits))
  459.                lo hi))))
  460.        (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)
  461.                  (internal-sxhash (denominator s-expr) 0))))
  462.        (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)
  463.                    (internal-sxhash (imagpart s-expr) 0))))))
  464.     (array
  465.      (typecase s-expr
  466.        (string (sxhash-string s-expr))
  467.        (t (array-rank s-expr))))
  468.     ;; Everything else.
  469.     (t 42)))
  470.  
  471.  
  472.  
  473. ;;;; WITH-HASH-TABLE-ITERATOR
  474.  
  475. (defmacro with-hash-table-iterator ((function hash-table) &body body)
  476.   "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
  477.    provides a method of manually looping over the elements of a hash-table.
  478.    function is bound to a generator-macro that, withing the scope of the
  479.    invocation, returns three values.  First, whether there are any more objects
  480.    in the hash-table, second, the key, and third, the value."
  481.   (let ((counter (gensym))
  482.     (pointer (gensym))
  483.     (table (gensym))
  484.     (size (gensym))
  485.     (the-table (gensym)))
  486.     `(let* ((,the-table ,hash-table)
  487.         (,table (hash-table-table ,the-table))
  488.         (,size (hash-table-size ,the-table))
  489.         (,counter 0)
  490.         (,pointer nil))
  491.        (macrolet ((,function ()
  492.              `(loop
  493.             (when (= ,',counter ,',size) (return))
  494.             (let ((bucket (or ,',pointer
  495.                       (aref ,',table ,',counter))))
  496.               (when bucket
  497.                 (cond ((cdr bucket)
  498.                    (setf ,',pointer (cdr bucket)))
  499.                   (t
  500.                    (setf ,',pointer nil)
  501.                    (incf ,',counter)))
  502.                 (return (values t (caar bucket) (cdar bucket)))))
  503.             (incf ,',counter))))
  504.      ,@body))))
  505.  
  506.  
  507.  
  508. ;;;; Dumping one as a constant.
  509.  
  510. (defun make-hash-table-load-form (table)
  511.   (values
  512.    `(make-hash-table
  513.      :test ',(hash-table-kind table) :size ',(hash-table-size table)
  514.      :hash-table-rehash-size ',(hash-table-rehash-size table)
  515.      :hash-table-rehash-threshold ',(hash-table-rehash-threshold table))
  516.    (let ((sets nil))
  517.      (with-hash-table-iterator (next table)
  518.        (loop
  519.      (multiple-value-bind (more key value) (next)
  520.        (if more
  521.            (setf sets (list* `(gethash ',key ,table) `',value sets))
  522.            (return)))))
  523.      (if sets
  524.      `(setf ,@sets)
  525.      nil))))
  526.