(FILECREATED "22-Aug-86 14:22:15" {ERIS}<LISPCORE>LIBRARY>CMLHASH.;15
 6938   

      changes to:  (VARS CMLHASHCOMS)
                   (VARIABLES SXHASH-MAX)
                   (FUNCTIONS CL:MAPHASH CL:PUTHASH HASH-TABLE-COUNT HASH-TABLE-P MAKE-HASH-TABLE 
                          SXHASH SXHASH-STRING EQLHASHBITSFN)

      previous date: " 2-Jul-86 13:44:14" {ERIS}<LISPCORE>LIBRARY>CMLHASH.;14)


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

(PRETTYCOMPRINT CMLHASHCOMS)

(RPAQQ CMLHASHCOMS
 ((* ;; "External interface")
                    (SETFS CL:GETHASH)
                    (FUNCTIONS CL:MAPHASH CL:PUTHASH HASH-TABLE-COUNT HASH-TABLE-P MAKE-HASH-TABLE 
                           SXHASH)
                    (P (MOVD (QUOTE GETHASH)
                             (QUOTE CL:GETHASH)))
                    (* ;; "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:PUTHASH
 (KEY HASH-TABLE VALUE &OPTIONAL DEFAULT) (PUTHASH KEY VALUE HASH-TABLE))

(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))))

(MOVD (QUOTE GETHASH)
      (QUOTE CL:GETHASH))



(* ;; "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)))))

(DEFMACRO EQLHASHBITSFN
 (OBJ) (BQUOTE (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