(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED " 2-Apr-92 13:37:38" IL:|{DSK}local>lde>lispcore>sources>CMLHASH.;6| 16577 IL:|changes| IL:|to:| (IL:FUNCTIONS CL:WITH-HASH-TABLE-ITERATOR) (IL:VARS IL:CMLHASHCOMS) IL:|previous| IL:|date:| " 1-Apr-92 13:16:01" IL:|{DSK}local>lde>lispcore>sources>CMLHASH.;4| ) ; Copyright (c) 1985, 1986, 1987, 1989, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLHASHCOMS) (IL:RPAQQ IL:CMLHASHCOMS ( (IL:* IL:|;;| "External interface") (IL:FUNCTIONS MAKE-HASH-TABLE GETHASH MAPHASH HASH-TABLE-COUNT HASH-TABLE-P SXHASH) (XCL:OPTIMIZERS GETHASH HASH-TABLE-COUNT HASH-TABLE-P) (IL:SETFS GETHASH) (IL:FUNCTIONS CL:HASH-TABLE-REHASH-SIZE CL:HASH-TABLE-REHASH-THRESHOLD CL:HASH-TABLE-SIZE CL:HASH-TABLE-TEST CL:WITH-HASH-TABLE-ITERATOR) (XCL:OPTIMIZERS CL:HASH-TABLE-REHASH-SIZE CL:HASH-TABLE-SIZE CL:HASH-TABLE-TEST) (IL:* IL:|;;| "Internal interface") (IL:FUNCTIONS EQLHASHBITSFN SXHASH-PATHNAME) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES SXHASH-MAX) (IL:FUNCTIONS SXHASH-LIST SXHASH-STRING SXHASH-BIT-VECTOR SXHASH-ROT)) (IL:* IL:|;;| "UFN for the SXHASH opcode (a MISCN)") (IL:FNS SXHASH-UFN EQLHASHBITSFN-UFN %SXHASH) (IL:FUNCTIONS CL::%SXHASH-EQUALP SXHASH-EQUALP-STRING) (XCL:OPTIMIZERS SXHASH EQLHASHBITSFN) (XCL:OPTIMIZERS IL:STRINGHASHBITS IL:STRING-EQUAL-HASHBITS) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLHASH))) (IL:* IL:|;;| "External interface") (DEFUN MAKE-HASH-TABLE (&KEY (TEST 'EQL) (SIZE 65) REHASH-SIZE REHASH-THRESHOLD) (IL:* IL:\; "Edited 23-Mar-92 16:27 by jrb:") (IL:* IL:|;;| "Creates and returns a hash table. See manual for details.") (IF (NOT (SYMBOLP TEST)) (COND ((%EQCODEP TEST 'EQ) (SETQ TEST 'EQ)) ((%EQCODEP TEST 'EQL) (SETQ TEST 'EQL)) ((%EQCODEP TEST 'EQUAL) (SETQ TEST 'EQUAL)) ((%EQCODEP TEST 'EQUALP) (SETQ TEST 'EQUALP)))) (ECASE TEST (EQ (IL:HASHARRAY SIZE REHASH-SIZE)) (EQL (IL:HASHARRAY SIZE REHASH-SIZE 'EQLHASHBITSFN 'EQL)) (EQUAL (IL:HASHARRAY SIZE REHASH-SIZE 'SXHASH 'EQUAL)) (EQUALP (IL:* IL:|;;| "NOTE: CL::%SXHASH-EQUALP has no microcode/C support and is hence SLOW") (IL:HASHARRAY SIZE REHASH-SIZE 'CL::%SXHASH-EQUALP 'EQUALP)))) (DEFUN GETHASH (KEY HASHTABLE &OPTIONAL DEFAULT) (IL:GETHASH KEY HASHTABLE DEFAULT T)) (DEFUN MAPHASH (FN HASH-TABLE) "Call function with each key/value pair in the hash-table" (IL:MAPHASH HASH-TABLE #'(LAMBDA (VALUE KEY) (FUNCALL FN KEY VALUE))) NIL) (DEFUN HASH-TABLE-COUNT (HASH-TABLE) (IL:HARRAYPROP HASH-TABLE 'IL:NUMKEYS)) (DEFUN HASH-TABLE-P (OBJECT) (IL:TYPENAMEP OBJECT 'IL:HARRAYP)) (DEFUN SXHASH (OBJECT) (IL:MISCN SXHASH OBJECT)) (XCL:DEFOPTIMIZER GETHASH (KEY HASHTABLE &OPTIONAL DEFAULT XCL:&CONTEXT CONTEXT) (IF (EQ 1 (COMPILER:CONTEXT-VALUES-USED CONTEXT)) (IF DEFAULT `(IL:GETHASH ,KEY ,HASHTABLE ,DEFAULT) `(IL:GETHASH ,KEY ,HASHTABLE)) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER HASH-TABLE-COUNT (HASH-TABLE) `(IL:HARRAYPROP ,HASH-TABLE 'IL:NUMKEYS)) (XCL:DEFOPTIMIZER HASH-TABLE-P (OBJECT) `(IL:TYPENAMEP ,OBJECT 'IL:HARRAYP)) (DEFSETF GETHASH PUTHASH) (DEFUN CL:HASH-TABLE-REHASH-SIZE (HASH-TABLE) (IL:HARRAYPROP HASH-TABLE 'IL:OVERFLOW)) (DEFUN CL:HASH-TABLE-REHASH-THRESHOLD (HASH-TABLE) 1) (DEFUN CL:HASH-TABLE-SIZE (HASH-TABLE) (IL:HARRAYSIZE HASH-TABLE)) (DEFUN CL:HASH-TABLE-TEST (HASH-TABLE) (IL:* IL:\; "Edited 22-Mar-92 20:47 by jrb:") (LET ((CL::TEST (IL:HARRAYPROP HASH-TABLE 'IL:EQUIVFN))) (CASE CL::TEST ((NIL) 'EQ) (T CL::TEST)))) (DEFMACRO CL:WITH-HASH-TABLE-ITERATOR ((CL::MNAME HASH-TABLE) &REST CL::FORMS) (LET ((IL:HA (GENSYM)) (IL:LASTSLOT (GENSYM)) (IL:NULLVALUE (GENSYM)) (IL:SLOT (GENSYM)) (IL:V (GENSYM))) (IL:* IL:|;;| "The code below is actually this stuff, macroexpanded to remove references to the IL:HARRAYP record and all the grossly internal stuff in it, which aren't normally in the sysout") (IL:* IL:|;;| "`(LET* ((,IL:HA (IL:\\\\DTEST ,HASH-TABLE 'IL:HARRAYP)) (,IL:LASTSLOT (IL:|fetch| (IL:HASHSLOT IL:NEXTSLOT) IL:|of| (IL:\\\\HASHSLOT (IL:|fetch| IL:HARRAYPBASE IL:|of| ,IL:HA) (IL:|fetch| (IL:HARRAYP IL:LASTINDEX) IL:|of| ,IL:HA)))) (,IL:NULLVALUE IL:\\\\HASH.NULL.VALUE) ,IL:SLOT ,IL:V) (FLET ((,MNAME ( (IL:|until| (EQ (IL:SETQ ,IL:SLOT (IF ,IL:SLOT (IL:|fetch| (IL:HASHSLOT IL:NEXTSLOT) IL:|of| ,IL:SLOT) (IL:|fetch| IL:HARRAYPBASE IL:|of| ,IL:HA))) ,IL:LASTSLOT) IL:|when| (IL:SETQ ,IL:V (IL:|fetch| (IL:HASHSLOT IL:VALUE) IL:|of| ,IL:SLOT)) IL:|do| (RETURN (VALUES T (IL:|fetch| (IL:HASHSLOT IL:KEY) IL:|of| ,IL:SLOT) (AND (IL:NEQ ,IL:V ,IL:NULLVALUE) ,IL:V))) IL:|finally| (RETURN NIL)))) ,@FORMS))") `(LET* ((,IL:HA (IL:\\DTEST ,HASH-TABLE 'IL:HARRAYP)) (,IL:LASTSLOT (IL:\\ADDBASE (IL:\\ADDBASE (IL:FETCHFIELD '(IL:HARRAYP 2 IL:POINTER) ,IL:HA) (IL:LLSH (IL:FETCHFIELD '(IL:HARRAYP 1 (IL:BITS . 15)) ,IL:HA) 2)) 4)) (,IL:NULLVALUE IL:\\HASH.NULL.VALUE) ,IL:SLOT ,IL:V) (FLET ((,CL::MNAME NIL (IL:|until| (EQ (IL:SETQ ,IL:SLOT (IF ,IL:SLOT (IL:\\ADDBASE ,IL:SLOT 4) (IL:FETCHFIELD '(IL:HARRAYP 2 IL:POINTER) ,IL:HA))) ,IL:LASTSLOT) IL:|when| (IL:SETQ ,IL:V (IL:FETCHFIELD '(NIL 2 IL:POINTER) ,IL:SLOT)) IL:|do| (RETURN (VALUES T (IL:FETCHFIELD '(NIL 0 IL:POINTER) ,IL:SLOT) (AND (IL:NEQ ,IL:V ,IL:NULLVALUE) ,IL:V))) IL:|finally| (RETURN NIL)))) ,@CL::FORMS)))) (XCL:DEFOPTIMIZER CL:HASH-TABLE-REHASH-SIZE (HASH-TABLE) `(IL:HARRAYPROP ,HASH-TABLE 'IL:OVERFLOW)) (XCL:DEFOPTIMIZER CL:HASH-TABLE-SIZE (HASH-TABLE) `(IL:HARRAYSIZE ,HASH-TABLE)) (XCL:DEFOPTIMIZER CL:HASH-TABLE-TEST (HASH-TABLE) `(LET ((CL::TEST (IL:HARRAYPROP ,HASH-TABLE 'IL:EQUIVFN))) (CASE CL::TEST ((NIL) 'EQ) (T CL::TEST)))) (IL:* IL:|;;| "Internal interface") (DEFUN EQLHASHBITSFN (OBJ) (IL:MISCN EQLHASHBITSFN OBJ)) (DEFUN SXHASH-PATHNAME (PATHNAME) (LET ((HASH (SXHASH-ROT (LOGXOR (%SXHASH (IL:%PATHNAME-HOST PATHNAME)) (%SXHASH (IL:%PATHNAME-DEVICE PATHNAME)))))) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-TYPE PATHNAME))))) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-VERSION PATHNAME))))) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-DIRECTORY PATHNAME))))) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-NAME PATHNAME))))))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFCONSTANT SXHASH-MAX 13) (DEFMACRO SXHASH-LIST (LIST) `(DO ((LIST ,LIST (CDR LIST)) (INDEX 0 (1+ INDEX)) (HASH 0)) ((OR (NOT (CONSP LIST)) (EQ INDEX SXHASH-MAX)) HASH) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (CAR LIST))))))) (DEFMACRO SXHASH-STRING (STRING) (IL:* IL:\;  "Returns hash value for a general string.") `(DO ((I 0 (1+ I)) (LENGTH (MIN (LENGTH ,STRING) SXHASH-MAX)) (HASH 0)) ((EQ I LENGTH) HASH) (IL:* IL:|;;| "the spice code had a fairly general \"rotate X within integerlength of most-positive-fixnum bits, but (a) it was slow and (b) it was buggy anyway, since it assumed that most-positive-fixnum was 1 less than a power of two.") (SETQ HASH (SXHASH-ROT (LOGXOR HASH (CHAR-INT (AREF ,STRING I))))))) (DEFMACRO SXHASH-BIT-VECTOR (BIT-VECTOR) `(DO ((I 0 (1+ I)) (LENGTH (MIN (LENGTH ,BIT-VECTOR) 16)) (HASH 0)) ((EQ I LENGTH) HASH) (SETQ HASH (+ (ASH HASH 1) (AREF ,BIT-VECTOR I))))) (DEFMACRO SXHASH-ROT (X) `(LET ((X ,X)) (DPB X (BYTE 9 7) (LDB (BYTE 7 9) X)))) ) (IL:* IL:|;;| "UFN for the SXHASH opcode (a MISCN)") (IL:DEFINEQ (SXHASH-UFN (IL:LAMBDA (IL:INDEX IL:ARGCOUNT IL:ARG-PTR) (IL:* IL:\; "Edited 23-Feb-89 19:45 by jds") (IL:* IL:|;;|  "This is the UFN for the CL:SXHASH MISCN sub-opcode. That MISCN is being implemented on Suns.") (%SXHASH (IL:\\GETBASEPTR IL:ARG-PTR 0)))) (EQLHASHBITSFN-UFN (IL:LAMBDA (IL:INDEX IL:ARGCOUNT IL:ARG-PTR) (IL:* IL:\; "Edited 23-Feb-89 18:10 by jds") (LET ((OBJ (IL:\\GETBASEPTR IL:ARG-PTR 0))) (TYPECASE OBJ (CHARACTER (CHAR-INT OBJ)) (INTEGER (LOGAND OBJ 65535)) (FLOAT (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| OBJ) (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| OBJ))) (RATIO (LOGXOR (EQLHASHBITSFN (NUMERATOR OBJ)) (EQLHASHBITSFN (DENOMINATOR OBJ)))) (COMPLEX (LOGXOR (EQLHASHBITSFN (REALPART OBJ)) (EQLHASHBITSFN (IMAGPART OBJ)))) (T (IL:\\EQHASHINGBITS OBJ)))))) (%SXHASH (IL:LAMBDA (OBJECT) (IL:* IL:\; "Edited 23-Feb-89 19:42 by jds") (COND ((SYMBOLP OBJECT) (IL:\\EQHASHINGBITS OBJECT)) ((LISTP OBJECT) (SXHASH-LIST OBJECT)) ((NUMBERP OBJECT) (TYPECASE OBJECT (INTEGER (LOGAND OBJECT MOST-POSITIVE-FIXNUM)) (FLOAT (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| OBJECT) (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| OBJECT))) (RATIO (LOGXOR (%SXHASH (NUMERATOR OBJECT)) (%SXHASH (DENOMINATOR OBJECT)))) (COMPLEX (LOGXOR (%SXHASH (REALPART OBJECT)) (%SXHASH (IMAGPART OBJECT)))))) ((STRINGP OBJECT) (SXHASH-STRING OBJECT)) ((BIT-VECTOR-P OBJECT) (SXHASH-BIT-VECTOR OBJECT)) ((PATHNAMEP OBJECT) (SXHASH-PATHNAME OBJECT)) (T (IL:\\EQHASHINGBITS OBJECT))))) ) (DEFUN CL::%SXHASH-EQUALP (CL::OBJECT) (IL:* IL:\; "Edited 23-Mar-92 16:17 by jrb:") (COND ((SYMBOLP CL::OBJECT) (IL:\\EQHASHINGBITS CL::OBJECT)) ((LISTP CL::OBJECT) (SXHASH-LIST CL::OBJECT)) ((NUMBERP CL::OBJECT) (IL:* IL:|;;| "Hacks for numbers for hash key purposes:") (IL:* IL:|;;| "FLOATs that can be coerced to integer are") (IL:* IL:|;;| "RATIOs are coerecd to floats (it would be better to coerce non-integral FLOATs to RATIOs, but a real pain in the ass; this is probably good enough...)") (TYPECASE CL::OBJECT (INTEGER (LOGAND CL::OBJECT MOST-POSITIVE-FIXNUM)) (FLOAT (IF (= CL::OBJECT (FLOOR CL::OBJECT)) (MULTIPLE-VALUE-BIND (CL::MANT EXP CL::SIGN) (INTEGER-DECODE-FLOAT CL::OBJECT) (SETQ CL::OBJECT (ASH CL::MANT EXP)) (WHEN (MINUSP CL::SIGN) (SETQ CL::OBJECT (IL:IMINUS CL::OBJECT))) (LOGAND CL::OBJECT MOST-POSITIVE-FIXNUM)) (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| CL::OBJECT) (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| CL::OBJECT)))) (RATIO (LET ((CL::F (COERCE CL::OBJECT 'FLOAT))) (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| CL::F) (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| CL::F)))) (COMPLEX (LOGXOR (%SXHASH (REALPART CL::OBJECT)) (%SXHASH (IMAGPART CL::OBJECT)))))) ((STRINGP CL::OBJECT) (SXHASH-EQUALP-STRING CL::OBJECT)) ((BIT-VECTOR-P CL::OBJECT) (SXHASH-BIT-VECTOR CL::OBJECT)) ((PATHNAMEP CL::OBJECT) (SXHASH-PATHNAME CL::OBJECT)) (T (IL:\\EQHASHINGBITS CL::OBJECT)))) (DEFMACRO SXHASH-EQUALP-STRING (STRING) (IL:* IL:|;;| "Returns EQUALP hash value for a string") `(DO ((I 0 (1+ I)) (LENGTH (MIN (LENGTH ,STRING) SXHASH-MAX)) (HASH 0)) ((EQ I LENGTH) HASH) (IL:* IL:|;;| "the spice code had a fairly general \"rotate X within integerlength of most-positive-fixnum bits, but (a) it was slow and (b) it was buggy anyway, since it assumed that most-positive-fixnum was 1 less than a power of two.") (SETQ HASH (SXHASH-ROT (LOGXOR HASH (IL:%CHAR-UPCASE-CODE (CHAR-CODE (AREF ,STRING I)))))))) (XCL:DEFOPTIMIZER SXHASH (OBJECT) `(IL:MISCN SXHASH ,OBJECT)) (XCL:DEFOPTIMIZER EQLHASHBITSFN (OBJECT) `(IL:MISCN EQLHASHBITSFN ,OBJECT)) (XCL:DEFOPTIMIZER IL:STRINGHASHBITS (STRING) `(IL:MISCN IL:STRINGHASHBITS ,STRING)) (XCL:DEFOPTIMIZER IL:STRING-EQUAL-HASHBITS (STRING) `(IL:MISCN IL:STRING-EQUAL-HASHBITS ,STRING)) (IL:PUTPROPS IL:CMLHASH IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:CMLHASH IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:PUTPROPS IL:CMLHASH IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1989 1990 1992)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (11187 13240 (SXHASH-UFN 11200 . 11499) (EQLHASHBITSFN-UFN 11501 . 12240) (%SXHASH 12242 . 13238))))) IL:STOP