(FILECREATED "15-Oct-86 17:07:22" {ERIS}<LISPCORE>SOURCES>CMLHASH.;4
 6407   

      changes to:  (FUNCTIONS CL:GETHASH)
                   (VARS CMLHASHCOMS)

      previous date: "22-Aug-86 17:03:54" {ERIS}<LISPCORE>SOURCES>CMLHASH.;2)


(* "
Copyright (c) 1985, 1986 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT CMLHASHCOMS)

(RPAQQ CMLHASHCOMS
 ((* ;; "External interface")
                    (SETFS CL:GETHASH)
                    (FUNCTIONS CL:MAPHASH CL:GETHASH CL:PUTHASH HASH-TABLE-COUNT HASH-TABLE-P 
                           MAKE-HASH-TABLE SXHASH)
                    (* ;; "Internal interface")
                    (VARIABLES SXHASH-MAX)
                    (FUNCTIONS SXHASH-LIST SXHASH-ROT SXHASH-STRING EQLHASHBITSFN \EQHASHINGBITS)
                    (PROP FILETYPE CMLHASH)))



(* ;; "External interface")


(DEFSETF CL:GETHASH
 CL:PUTHASH)

(DEFUN CL:MAPHASH
 (FUNCTION HASH-TABLE) "Call function with each key/value pair in the hash-table"
   (MAPHASH HASH-TABLE (CL:FUNCTION (CL:LAMBDA (VALUE KEY)
                                           (FUNCALL FUNCTION KEY VALUE))))
   NIL)

(DEFUN CL:GETHASH
 (KEY HASHTABLE &OPTIONAL DEFAULT) (GETHASH KEY HASHTABLE DEFAULT T))

(DEFUN CL:PUTHASH
 (KEY HASH-TABLE VALUE &OPTIONAL DEFAULT) (\HASHACCESS KEY VALUE HASH-TABLE NIL)
                                                           VALUE)

(DEFUN HASH-TABLE-COUNT
 (HASH-TABLE) (HARRAYPROP HASH-TABLE (QUOTE NUMKEYS)))

(DEFUN HASH-TABLE-P
 (OBJECT) (HARRAYP OBJECT))

(DEFUN MAKE-HASH-TABLE
 (&KEY (TEST (QUOTE EQL))
                             (SIZE 65)
                             REHASH-SIZE REHASH-THRESHOLD) 
                                         "Creates and returns a hash table.  See manual for details."
   (AND (NOT (SYMBOLP TEST))
        (COND
           ((EQP TEST (CL:FUNCTION EQ
))
            (SETQ TEST (QUOTE EQ
)))
           ((EQP TEST (CL:FUNCTION EQL))
            (SETQ TEST (QUOTE EQL)))
           ((EQP TEST (CL:FUNCTION CL:EQUAL))
            (SETQ TEST (QUOTE CL:EQUAL)))))
   (ECASE TEST (EQ (HASHARRAY SIZE REHASH-SIZE))
          (EQL (HASHARRAY SIZE REHASH-SIZE (FUNCTION EQLHASHBITSFN)
                      (FUNCTION EQL)))
          (CL:EQUAL (HASHARRAY SIZE REHASH-SIZE (FUNCTION SXHASH)
                           (FUNCTION CL:EQUAL)))))

(DEFUN SXHASH
 (OBJECT) "Returns a fixnum equal hash for an object."
   (TYPECASE OBJECT (SYMBOL (STRINGHASHBITS (SYMBOL-NAME OBJECT)))
          (STRING (SXHASH-STRING OBJECT))
          (LIST (SXHASH-LIST OBJECT))
          (ARRAY (ARRAY-RANK OBJECT))
          (FLOAT (LOGXOR (fetch (FLOATP HIWORD)
                                of OBJECT)
                        (fetch (FLOATP LOWORD)
                               of OBJECT)))
          (INTEGER (LOGAND OBJECT 65535))
          (RATIO (LOGXOR (SXHASH (NUMERATOR OBJECT))
                        (SXHASH (DENOMINATOR OBJECT))))
          (COMPLEX (LOGXOR (SXHASH (REALPART OBJECT))
                          (SXHASH (IMAGPART OBJECT))))
          (T (\EQHASHINGBITS OBJECT))))




(* ;; "Internal interface")


(DEFCONSTANT SXHASH-MAX
 13)

(DEFMACRO SXHASH-LIST
 (SEQUENCE) (BQUOTE (CL:DO ((SEQUENCE (\, SEQUENCE)
                                                        (CDR SEQUENCE))
                                                 (INDEX 0 (1+ INDEX))
                                                 (HASH 2))
                                                ((OR (ATOM SEQUENCE)
                                                     (= INDEX SXHASH-MAX))
                                                 HASH)
                                                (DECLARE (TYPE FIXNUM HASH))
                                                (SETQ HASH (SXHASH-ROT (LOGXOR HASH
                                                                              (SXHASH (CAR SEQUENCE))
                                                                              )
                                                                  7)))))

(DEFMACRO SXHASH-ROT
 (X NUM) "Rotates x left by num bits." (BQUOTE (ROT (\, X)
                                                                        (\, NUM)
                                                                        (\, (INTEGERLENGTH 
                                                                                 MOST-POSITIVE-FIXNUM
                                                                                   )))))

(DEFMACRO SXHASH-STRING
 (SEQUENCE) "Returns hash value for a non-simple string."
   (BQUOTE (CL:DO ((I 0 (1+ I))
                   (LENGTH (MIN (CL:LENGTH (\, SEQUENCE))
                                SXHASH-MAX))
                   (HASH 0))
                  ((= I LENGTH)
                   HASH)
                  (DECLARE (TYPE FIXNUM I LENGTH HASH))
                  (SETQ HASH (SXHASH-ROT (LOGXOR HASH (CHAR-INT (AREF (\, SEQUENCE)
                                                                      I)))
                                    7)))))

(DEFUN EQLHASHBITSFN
 (OBJ) (TYPECASE OBJ (CHARACTER)
                                  (INTEGER (LOGAND OBJ 65535))
                                  (FLOAT (LOGXOR (fetch (FLOATP HIWORD)
                                                        of OBJ)
                                                (fetch (FLOATP LOWORD)
                                                       of OBJ)))
                                  (RATIO (LOGXOR (EQLHASHBITSFN (NUMERATOR OBJ))
                                                (EQLHASHBITSFN (DENOMINATOR OBJ))))
                                  (COMPLEX (LOGXOR (EQLHASHBITSFN (REALPART OBJ))
                                                  (EQLHASHBITSFN (IMAGPART OBJ))))
                                  (T (\EQHASHINGBITS OBJ))))

(DEFMACRO \EQHASHINGBITS
 (X) (BQUOTE (LOGXOR (\HILOC (\, X))
                                            (LOGXOR (LLSH (LOGAND (\LOLOC (\, X))
                                                                 8191)
                                                          3)
                                                   (LRSH (\LOLOC (\, X))
                                                         9)))))


(PUTPROPS CMLHASH FILETYPE
 COMPILE-FILE)
(PUTPROPS CMLHASH COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL)))
STOP