LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031437. :SYSTEM-TYPE :LOGICAL :VERSION 14. :TYPE "LISP" :NAME "HASH" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758640237. :AUTHOR "REL3" :LENGTH-IN-BYTES 41694. :LENGTH-IN-BLOCKS 41. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                ; -*-cold-load:t;  Mode:common-Lisp; Package:System-Internals; Base:8 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;A hash table that the user sees is a flavor instance.;The guts of it is a named-structure array defined below.;The contents of the array is divided into n-word blocks.;Each block corresponds to one hash key.  The first word of the block is the key.;The remaining words are associated data.  Normally there is only one of them.;Each key and its associated data words form a cdr-next list.;The third value of GETHASH points to this list.;Extra args to PUTHASH can be used to set data words past the first.;A DTP-NULL is used in the table in the key position to mark an empty slot.;DTP-NULL with nonzero pointer means a slot that was "deleted" and;which search must continue past.;A flavor's method hash table is actually the array, not the flavor instance.;The array points to the flavor instance it belongs to, so that the;flavor code can find the instance to send messages to it.;This also enables flavors to be bootstrapped.;This file defines only the non flavor hash support;The file HASHFL, loaded after flavors are loaded,;defines the hash table flavors which are used only as mixins.;phd 2/27/86 add a binding to prevent scavenging while accessing hash tables.;;PHD 1/2/87 Added INLINE declaration for HASH-TABLE-P inside PUTHASH and GETHASH;;PHD optimizes clrhash for trivial cases (the hash table is empty).(proclaim '(inline follow-structure))(PROCLAIM '(special %gc-generation-number))(defun follow-structure (x)  (WITHOUT-INTERRUPTS     (do ((x x (%MAKE-POINTER (%DATA-TYPE X) (%P-CONTENTS-AS-LOCATIVE X))))((/= (%P-DATA-TYPE X) DTP-HEADER-FORWARD) x))))(defsubst hash-table-funcallable-p (hash-table)  (and (array-has-leader-p hash-table)       (not (zerop      (LDB %%array-leader-funcall-as-hash-table    (%p-pointer-offset hash-table -1))))));; TGC      (%p-ldb-offset %%array-leader-funcall-as-hash-table hash-table -1))))) ;; TGC - Don't rehash if not really necessary.(proclaim '(inline rehash-for-gc))(DEFUN rehash-for-gc (HASH-TABLE)  "THIS PREDICATE IS USED TO DETERMINE IF A HASH-TABLE NEEDS A REHASHBECAUSE OF A GC-FLIP."  (if (FBOUNDP 'gc-need-rehash-p)      (funcall 'gc-need-rehash-p hash-table)      (/= (hash-table-gc-generation-number hash-table) %gc-generation-number)));Note: the microcode knows the index of HASH-TABLE-MODULUS;as well as the organization of the entries and how to hash them,;in the special case that the modulus is a power of 2.;See label CALL-INSTANCE-ARRAY in the microcode.(defstruct (hash-table :named :ARRAY-LEADER  (:constructor make-hash-array-internal) (:conc-name nil)       (:callable-constructors nil) (:copier nil))   (hash-table-rehash-function 'hash-table-rehash);A function when rehash is required.  First argument is the hash-table,;second is NIL to just rehash or the rehash-size to grow it first.;The function must return the hash-table (which may have been moved;by adjust-array-size)    (hash-table-rehash-size 1.3);How much to grow by when the time comes.  A flonum is the ratio to;increase by, a fixnum is the number of entries to add.;These will get rounded up to the next appropriate size.    (hash-table-gc-generation-number %gc-generation-number);Used to decide when rehash required because the GC may have moved;some objects, changing their %POINTER and hence their hash code.    hash-table-modulus;The number of blocks.  Used for remainder to get hash code.    (hash-table-fullness 0);The number of valid entries currently in the array.    (hash-table-block-length 2)  (hash-table-rehash-threshold 0.7s0);Rehash if we get more than this fraction full.    (hash-table-number-of-deleted-entries 0);Number of "deleted" entries (entries no longer valid;but which you must keep searching past).;Used together with the FULLNESS to make sure there is always one;slot that has never been used.    (hash-table-lock ())  ;This function computes a numeric key from an object.  NIL means use the object.  hash-table-hash-function  ;This function compares an object key with a key in the table.  (hash-table-compare-function 'eq);This is the instance whose HASH-ARRAY we are.  hash-table-instance) ;;;PHD 6/23/86 Added new Common Lisp functions(defun hash-table-size (hash-table)  "returns the size of the hash-table (in entries)"  (check-type hash-table hash-table )  (/ (array-total-size hash-table) (hash-table-block-length hash-table)))(defun hash-table-test (hash-table)  "returns the test function of hash-table"  (check-type hash-table hash-table)  (case (hash-table-compare-function hash-table)       (nil #'eq)       (equal-hash #'equal)       (eql-hash #'eql)))(DEFUN EQUAL-HASH (KEY) (SXHASH KEY nil));; TGC(DEFUN EQL-HASH (KEY)  (IF (AND (NUMBERP KEY) (NOT (FIXNUMP KEY)))      (SXHASH KEY) KEY));Subroutine of hashing.;Given a hash-table and a key, return a locative to the start;of the block in the array which may contain an association from that key.;Cannot use ALOC because it gets an error if there is a DTP-NULL in the array.;;;(proclaim '(inline hash-block-pointer));;;(defun hash-block-pointer (hash-table key  blen modulus);;;  (%make-pointer-offset dtp-locative hash-table;;;     (+ (* (REM (ldb 23 (rot (%pointer key);;;     (if (hash-table-funcallable-p hash-table);;; 0;;; (case (%data-type key);;;       (#.dtp-fix 0);;;       (#.dtp-character 0);;;       (otherwise -2)))));;;modulus );;;   blen);;;(IF (not (ZEROP (%p-ldb-offset %%array-simple-bit hash-table 0)));-offset to follow str fwding;;;    1;;;    (1+ (%p-ldb-offset %%array-long-length-flag hash-table 0))))))(defsubst hash-block-pointer (hash-table key  blen modulus)  (%make-pointer-offset dtp-locative hash-table     (+ (* (REM (ldb 23 (rot (%pointer key)     (if (hash-table-funcallable-p hash-table) 0 (case   (%data-type key)   (#.dtp-symbol          -2)   (#.dtp-array           -1)   (#.dtp-list            -1)   (#.dtp-instance        -1)   (otherwise              0)   ))))modulus )   blen)(IF (not (ZEROP (%p-ldb-offset %%array-simple-bit hash-table 0)));-offset to follow str fwding    1    (1+ (%p-ldb-offset %%array-long-length-flag hash-table 0))))))(defsubst %p-contents-eq (p x)  (And (neq (%p-data-type p) dtp-null) (eq (car p) x)))(defun make-hash-array (&key &optional (size 100) area ((:rehash-function rhf) 'hash-table-rehash)  ((:rehash-size rhs) 1.3s0) growth-factor (number-of-values 1) actual-size  (rehash-threshold 0.7s0) funcallable-p hash-function (compare-function 'eq) test instance &aux  ht blen)  (cond    (funcallable-p;; Funcallable hash tables are looked at by the microcode     ;; and require that the modulus be a power of 2.          (setq rhf 'hash-table-double-size-rehash)     (setq size (or actual-size (lsh 1 (integer-length  size))))     (setq hash-function ())     (setq compare-function 'eq) (setq number-of-values 2))    (t (setq size (or actual-size (hash-table-good-size size)))))  (when test    (setq compare-function test)    (setq hash-function          (select test (('eq #'eq) nil) (('equal #'equal) 'equal-hash) (('eql #'eql) 'eql-hash)                  (t (ferror () "Argument TEST is not EQ, EQL or EQUAL.")))))  (when (integerp rehash-threshold)    (setq rehash-threshold (min .9s0 (/ (coerce rehash-threshold 'short-float) size))))  (setq blen (+ 1 number-of-values (if hash-function 1 0)))  (setq ht        (make-hash-array-internal :make-array (:LENGTH (* SIZE BLEN) :AREA AREA :TYPE ART-Q-LIST)                                  :hash-table-modulus size :hash-table-block-length blen                                  :hash-table-rehash-threshold rehash-threshold                                  :hash-table-rehash-function rhf :hash-table-rehash-size                                  (or growth-factor rhs) :hash-table-hash-function hash-function                                  :hash-table-compare-function compare-function                                  :HASH-TABLE-INSTANCE INSTANCE ))  (%p-store-pointer-offset    (DPB (if funcallable-p 1 0) %%array-leader-funcall-as-hash-table (%p-pointer-offset ht -1))    ht -1);; TGC  (%p-dpb-offset (if funcallable-p 1 0) %%array-leader-funcall-as-hash-table ht -1)  ;; Fix instance for flavors to point back to itself so the old code still works.  (when (and funcallable-p (null instance))    (setf (hash-table-instance ht ) ht))  (clear-hash-array ht)  ht);Convert SIZE (a number of array elements) to a more-or-less prime.(defun hash-table-good-size (size)  (or (oddp size) (setq size (1+ size)))  ;Find next higher more-or-less prime  (do ()      ((and (not (zerop (REM size 3))) (not (zerop (REM size 5))) (not (zerop (REM size 7)))))    (setq size (+ size 2)))  size) ;;; This is a separate function from the :CLEAR-HASH operation;;; for the sake of bootstrapping flavors.(defun clear-hash-array (hash-table )  "Clear out a hash array; leave it with no entries."  (with-lock ((hash-table-lock hash-table));; Set all of hash table to NIL with cdr-next.    (without-interrupts      (setf hash-table (follow-structure hash-table))              (setf (aref hash-table 0) ())             (%p-store-cdr-code (aloc hash-table 0) cdr-next)             (%blt-typed (aloc hash-table 0) (aloc hash-table 1)                         (1- (array-total-size hash-table)) 1)     ;; Set first word of each group to DTP-NULL, 0.             (let ((elt-0 (aloc hash-table 0))                   (blen (hash-table-block-length hash-table)))       (%P-STORE-DATA-TYPE-AND-POINTER elt-0 dtp-null 0);;TGC               (%p-store-pointer elt-0 0);;                  (%p-store-data-type elt-0 dtp-null)               (%blt-typed elt-0 (%make-pointer-offset dtp-locative elt-0 blen)                           (1- (truncate (array-total-size hash-table) blen)) blen)       ;; Set last word of each group to CDR-NIL               (%p-store-cdr-code (aloc hash-table (+ blen -1)) cdr-nil)               (%blt-typed (aloc hash-table (+ blen -1)) (aloc hash-table (+ blen blen -1))                           (1- (truncate (array-total-size hash-table) blen)) blen))             (setf (hash-table-fullness hash-table) 0)             (setf (hash-table-number-of-deleted-entries hash-table) 0)             (setf (hash-table-gc-generation-number hash-table) %gc-generation-number)             hash-table)));Named-structure handler(defun (:property hash-table named-structure-invoke) (message self &rest args)  (case message    (:which-operations '(:print-self :fasload-fixup))    (:fasload-fixup;Force rehash as if due to gc, because hash codes are all wrong now.     ;; Also fix up cdr codes.      (setf self (follow-structure self))        (setf (hash-table-gc-generation-number self) -1)       (do ((i 0 (+ i blen))    (blen (hash-table-block-length self))    (length (array-total-size self )))   ((>= i length)) (dotimes (j (1- blen))   (%p-store-cdr-code (aloc self (+ i j)) cdr-next)) (%p-store-cdr-code (aloc self (+ i blen -1)) cdr-nil)))     (:print-self       (let ((stream (car args)))       (format stream "#<~S-~A ~O>" (function-name (hash-table-compare-function self))               (if (hash-table-funcallable-p self) "HASH-TABLE (Funcallable)" "HASH-TABLE")               (%pointer self))))));;; Rehashing of hash arrays.;Add a new entry to a hash table being constructed for rehashing an old one.;CONTENTS is a pointer to the first word of the entry in the old hash table,;so its CAR is the hash code.;There is no need to lock the hash table since nobody else knows about it yet.(defun rehash-put (hash-table contents &optional for-gc &aux      (hash-code ;; Use the same hash code as before, to avoid swapping,;; unless this is rehashing due to GC.(if (and for-gc (hash-table-hash-function hash-table))    (funcall (hash-table-hash-function hash-table) (%p-contents-offset contents 1))    (car contents))))    (do* ((blen (hash-table-block-length hash-table)) (p (hash-block-pointer  hash-table hash-code  blen    (hash-table-modulus hash-table))    (%make-pointer-offset dtp-locative p blen)))(nil);; Make P wrap around at end of table.      ;; > is used because the pointer-difference, when time to wrap,      ;; is actually 1 or 2 more than the array length (because it includes the header);      ;; if BLEN is 2, we could wrap too soon if >= were used.            (if (> (%pointer-difference p hash-table) (array-total-size hash-table))  (setq p (%make-pointer-offset dtp-locative p (- (array-total-size hash-table)))))      ;; Install this key in the first empty slot.      ;; We know the key cannot already be present, and there are no deleted slots,      ;; and we don't need to rehash because that's what we are doing.      (cond((= (%p-data-type p) dtp-null) (%blt-typed contents p blen 1) (setf (car p) hash-code)       (return)))));Standard rehash function.  Returns new hash array (possibly the same one).;GROW is either the hash table's rehash-size or NIL meaning use same size array.;ACTUAL-SIZE is so that this can be used as a subroutine of another;rehash function which differs only in how to compute the new size.(defun hash-table-rehash (hash-table grow                  &optional actual-size &aux old-hash-table)  ;;;phd 3/7/86 Added without-interrupts so we can be sure  ;; that only one process will do that.  ;;  ;; Changed WITHOUT-INTERRUPTS to INHIBIT-GC-FLIPS.  Also changed PUTHASH and  ;; GETHASH callers to LOCK hash table before calling, and not call us from  ;; WITHOUT-INTERRUPTS.  3-24-87, -ab  (inhibit-gc-flips    (setq old-hash-table hash-table  hash-table (follow-structure hash-table))    (let* ((new-size     (if (null grow) (hash-table-modulus hash-table) (hash-table-good-size   (if (floatp grow) (floor (* (hash-table-modulus hash-table) grow))       (+ (hash-table-modulus hash-table) grow)))))   (new-hash-table     (make-hash-array :size new-size      :area (if grow (%area-number hash-table)background-cons-area)      :rehash-function (hash-table-rehash-function hash-table)      :rehash-size (hash-table-rehash-size hash-table)      :hash-function (hash-table-hash-function hash-table)      :compare-function (hash-table-compare-function hash-table)      :funcallable-p (hash-table-funcallable-p hash-table)      :instance (hash-table-instance hash-table)      :actual-size (if grow actual-size (hash-table-modulus hash-table))      :number-of-values  (- (hash-table-block-length hash-table) 1    (if (hash-table-hash-function hash-table) 1 0))      :rehash-threshold (hash-table-rehash-threshold hash-table))))      (declare (special new-hash-table))      ;; Scan the old hash table and find all nonempty entries.      (do ((p     (%make-pointer-offset dtp-locative hash-table   (if (plusp (%p-ldb %%array-simple-bit hash-table))       1       (1+ (%p-ldb %%array-long-length-flag hash-table))))     (%make-pointer-offset dtp-locative p blen))   (blen (hash-table-block-length hash-table))   (i 0 (+ i blen))   (n (array-total-size hash-table)))  ((>= i n))(cond  ((/= (%p-data-type p) dtp-null)   ;; And store each one in the new hash table.   (rehash-put new-hash-table p (null grow)))))      (setf (hash-table-fullness new-hash-table) (hash-table-fullness hash-table))      (cond((null grow) (setq hash-table (follow-structure-forwarding hash-table))     (setf (hash-table-lock new-hash-table) (hash-table-lock hash-table))     (%blt-typed (%find-structure-leader new-hash-table) (%find-structure-leader hash-table) (%structure-total-size hash-table) 1)     (return-array (prog1 new-hash-table (setf new-hash-table nil)))     hash-table)(t (structure-forward hash-table new-hash-table)   (when (= (%p-data-type old-hash-table) dtp-header-forward)     ;; Forwarded at least once already.  Skip intermediate structures.     (%P-STORE-DATA-TYPE-AND-POINTER old-hash-table DTP-Header-Forward new-hash-table)))))));; TGC     (%P-STORE-TAG-AND-POINTER old-hash-table DTP-Header-Forward new-hash-table)))))));Rehash a hash table to be exactly double the size.;Use this as a rehash function for a hash table.;It ignores the :REHASH-SIZE parameter.(defun hash-table-double-size-rehash (hash-table grow)  (hash-table-rehash hash-table grow (* 2 (hash-table-modulus hash-table))));;; The following functions should be obsolete now (PHD);;; The flavor system needs to be able to do PUTHASH before hash table flavors can be used.;(defun puthash-bootstrap (key value hash-table &rest additional-values &aux (values-left (cons value additional-values));  (hash-function (hash-table-hash-function hash-table));  (compare-function (hash-table-compare-function hash-table));  (hash-code (if hash-function (funcall hash-function key) key)));  (declare (values value old-value key-found-flag entry-pointer));  (with-lock ((hash-table-lock hash-table));             (setq hash-table (follow-structure-forwarding hash-table));             (do* ((blen (hash-table-block-length hash-table));                  (p (hash-block-pointer hash-table hash-code);                   (%make-pointer-offset dtp-locative p blen));                  (old-value);                  (emptyp ()));                 (nil);; Make P wrap around at end of table.;              ;; > is used because the pointer-difference, when time to wrap,;              ;; is actually 1 or 2 more than the array length (because it includes the header);;              ;; if BLEN is 2, we could wrap too soon if >= were used.              ;               (if (> (%pointer-difference p hash-table) (array-total-size hash-table));                   (setq p;                         (%make-pointer-offset dtp-locative p (- (array-total-size hash-table)))));               (cond;                 ((and (%p-contents-eq p hash-code);Found existing entry                       ;                       (or (null hash-function);                           (funcall compare-function (%p-contents-offset p 1) key)));                  (let ((value-index (if hash-function 2 1)));                    (setq old-value (%p-contents-offset p value-index));                    (do ((i value-index (1+ i)));                        ((= i blen));                      (%p-store-contents-offset (pop values-left) p i));                    (return value old-value t (%make-pointer-offset dtp-list p (1- value-index)))));                 ((= (%p-data-type p) dtp-null) (or emptyp (setq emptyp p));                  (when (zerop (%p-pointer p));; Hash tables are not supposed to need rehash before HASHFL is loaded.;                   ;; It wouldn't work, since the hash table instance is not there;                   ;; for FLAVOR to use to find the new hash array.                   ;                    (cond;                      ((rehash-for-gc hash-table);  ;; TGC (/= (hash-table-gc-generation-number hash-table) %gc-generation-number);                       (ferror () "~S claims to need rehash due to gc." hash-table));                      ((>=;                        (+ (hash-table-fullness hash-table);                           (hash-table-number-of-deleted-entries hash-table));                        (floor;                         (*;                          (if (floatp (hash-table-rehash-threshold hash-table));                              (hash-table-rehash-threshold hash-table) 0.7s0);                          (- (hash-table-modulus hash-table) 2))));                       (ferror () "~S is too full." hash-table));                      (t;Add to table using empty slot found;                        (%p-store-contents emptyp hash-code);                       (cond;                         (hash-function (%p-store-contents-offset key emptyp 1);                          (do ((i 2 (1+ i)));                              ((= i blen));                            (%p-store-contents-offset (pop values-left) emptyp i)));                         (t;                          (do ((i 1 (1+ i)));                              ((= i blen));                            (%p-store-contents-offset (pop values-left) emptyp i))));                       (incf (hash-table-fullness hash-table));; If reusing a deleted slot, decrement number of them slots.                       ;                       (or (eq emptyp p);                           (decf (hash-table-number-of-deleted-entries hash-table)));                       (return value))))))))) (unless (fboundp 'puthash-array)  (fset 'puthash-array 'puthash)) (unless (fboundp 'make-flavor-hash-array)  (fset 'make-flavor-hash-array 'make-flavor-hash-array-bootstrap)) (defun make-flavor-hash-array-bootstrap (area size)  (make-hash-array ':area area ':size size ':funcallable-p t ':rehash-threshold 0.8s0                   ':number-of-values 2))(fset 'maphash-array 'maphash);(defun maphash-array (function hash-table &rest extra-args );  (with-lock ((hash-table-lock hash-table));      (setq hash-table (follow-structure hash-table));             (do ((blen (hash-table-block-length hash-table));                  (block-offset (if (hash-table-hash-function hash-table) 1 0));                  (i 0 (+ i blen));                  (n (array-total-size hash-table)));                 ((>= i n));               (cond;                 ((/= (%p-data-type (aloc hash-table i)) dtp-null);                  (%open-call-block function 0 0);                  (dolist (i (%make-pointer-offset dtp-list (aloc hash-table i) block-offset));                    (%push i));                  (dolist (i extra-args);                    (%push i)) (%activate-open-call-block))));             hash-table));;; end of obsolete functions (PHD);;; Compatibility functions.(defun global:make-hash-table (&rest options )  "Create a hash table.  Keyword args are as follows:COMPARE-FUNCTION: the function for comparing the key against keys stored in the table.  Usually EQ or EQUAL.HASH-FUNCTION: the function to compute a hash code from a key. NIL (the default) is for EQ hash tables, and SI:EQUAL-HASH is used for EQUAL hash tables.TEST: Common Lisp way to specify the compare-function. It must be EQ, EQL or EQUAL.  A suitable hash function will be used automatically.AREA: area to cons the table in.SIZE: lower bound for number of entries (rounded up). Note that the table cannot actually hold that many keys.ACTUAL-SIZE: precise number of entries worth of size to use.NUMBER-OF-VALUES: number of values to associate with each key (default 1). Each PUTHASH can set all the values, and GETHASH retrieves them all.REHASH-THRESHOLD: a flonum between 0 and 1 (default 0.7). When that fraction of the table is full, it is made larger.REHASH-FUNCTION: a function which accepts a hash table and returns a larger one.REHASH-SIZE: the ratio by which the default REHASH-FUNCTION will increase the size of the table.  By default, 1.3. The keyword :GROWTH-FACTOR is synonymous with this."  (declare   (arglist &key &optional test compare-function hash-function area size actual-size            number-of-values rehash-threshold rehash-function rehash-size))  (apply 'make-hash-array  :allow-other-keys t options )) (DEFUN cli:MAKE-HASH-TABLE (&REST OPTIONS)  "Creates and returns a new hash table.TEST determines how keys are compared.  Use EQ, EQL or EQUAL.  The default is EQL.SIZE is the initial size of the table in entries, rounded up.REHASH-SIZE is the ratio by which the default REHASH-FUNCTION will increase the size of the table.  By default, 1.3.REHASH-THRESHOLD is a flonum between 0 and 1 (default 0.7). When that fraction of the table is full, it is made larger.COMPARE-FUNCTION: the function for comparing the key against keys stored in the table.  Ignored if TEST supplied.  Defaults to EQL.HASH-FUNCTION is the function to compute a hash code from a key. Ignored if TEST supplied.  Defaults to SI:EQL-HASH.AREA is the area to cons the table in.ACTUAL-SIZE is the precise number of entries to provide space for.NUMBER-OF-VALUES is the number of values to associate with each key (default 1).REHASH-FUNCTION is a function used to increase the size of the hash table."  (DECLARE   (ARGLIST &KEY TEST SIZE REHASH-SIZE REHASH-THRESHOLD &EXTENSION COMPARE-FUNCTION            HASH-FUNCTION AREA ACTUAL-SIZE NUMBER-OF-VALUES REHASH-FUNCTION))  (APPLY 'MAKE-hash-array         (COND           ((OR (MEMBER :TEST OPTIONS :TEST #'EQ)                (AND (MEMBER :COMPARE-FUNCTION OPTIONS :TEST #'EQ)                     (MEMBER :HASH-FUNCTION OPTIONS :TEST #'EQ)))            OPTIONS)           ((MEMBER :COMPARE-FUNCTION OPTIONS :TEST #'EQ)            (APPEND '(:HASH-FUNCTION EQL-HASH) OPTIONS))           ((MEMBER :HASH-FUNCTION OPTIONS :TEST #'EQ) (APPEND '(:COMPARE-FUNCTION EQL) OPTIONS))           (T (APPEND '(:TEST EQL) OPTIONS))))) (defun hash-table-count (hash-table)  "Returns the number of associations currently stored in HASH-TABLE."  (hash-table-fullness hash-table)) (defun clrhash (hash-table &optional ignore )  "Clear out a hash table; leave it with no entries."  (CHECK-ARG hash-table hash-table-p "a hash table")    (with-lock ((hash-table-lock hash-table))      (without-interrupts(when (and (zerop (hash-table-fullness hash-table))   (zerop (hash-table-number-of-deleted-entries hash-table)))  (return-from clrhash hash-table))(setq hash-table (follow-structure hash-table));; Set all of hash table to NIL with cdr-next.(setf (aref hash-table 0) ())(%p-store-cdr-code (aloc hash-table 0) cdr-next)(%blt-typed (aloc hash-table 0) (aloc hash-table 1) (1- (array-total-size hash-table)) 1);; Set first word of each group to DTP-NULL, 0.(let ((elt-0 (aloc hash-table 0))      (blen (hash-table-block-length hash-table)))  (%P-STORE-DATA-TYPE-AND-POINTER elt-0 DTP-Null 0);; TGC  (%p-store-pointer elt-0 0);;        (%p-store-data-type elt-0 dtp-null)  (%blt-typed elt-0 (%make-pointer-offset dtp-locative elt-0 blen)      (1- (truncate (array-total-size hash-table) blen)) blen)  ;; Set last word of each group to CDR-NIL.  (%p-store-cdr-code (aloc hash-table (+ blen -1)) cdr-nil)  (%blt-typed (aloc hash-table (+ blen -1)) (aloc hash-table (+ blen blen -1))      (1- (truncate (array-total-size hash-table) blen)) blen))(setf (hash-table-fullness hash-table) 0)(setf (hash-table-number-of-deleted-entries hash-table) 0)(setf (hash-table-gc-generation-number hash-table) %gc-generation-number)hash-table)))(defun gethash (key hash-table &optional default-value )  "Read the values associated with KEY in HASH-TABLE.Returns: 1) The primary value associated with KEY (DEFAULT-VALUE if KEY is not found), 2) a flag which is T if KEY was found, 3) a pointer to the list (inside the hash table)    which holds the key and the associated values    (NIL if KEY is not found)."  (declare (values value key-found-flag entry-pointer)   (inline hash-table-p))  (CHECK-ARG hash-table hash-table-p "a hash table")  (let* ((previous-inhibit-scheduling-flag inhibit-scheduling-flag);save scheduling state -ab (hash-function (hash-table-hash-function hash-table)) (compare-function (hash-table-compare-function hash-table)) (hash-code (if hash-function (funcall hash-function key) key)))    (with-lock-fast ((hash-table-lock hash-table))      (setq hash-table (follow-structure hash-table))      (do* ((blen (hash-table-block-length hash-table))    (p (hash-block-pointer hash-table hash-code  blen   (hash-table-modulus hash-table))       (%make-pointer-offset dtp-locative p blen)))   (nil);; Make P wrap around at end of table.              ;; > is used because the pointer-difference, when time to wrap,              ;; is actually 1 or 2 more than the array length (because it includes the header);              ;; if BLEN is 2, we could wrap too soon if >= were used.                             (if (> (%pointer-difference p hash-table) (array-total-size hash-table))                   (setq p                         (%make-pointer-offset dtp-locative p (- (array-total-size hash-table)))))               (and (%p-contents-eq p hash-code)                    (or (null hash-function)                        (funcall compare-function key (%p-contents-offset p 1)))                    (progn                      (if hash-function (setq p (%make-pointer-offset dtp-list p 1)))                      (return (%p-contents-offset p 1) t (%make-pointer dtp-list p))))       ;; If we find a slot that has never been used, this key is not present.               ;; We assume that not all slots are used!               (if (and (= (%p-data-type p) dtp-null) (zerop (%p-pointer p)))                   (cond                     ((rehash-for-gc hash-table)      ;; Some %POINTER's may have changed, try rehashing.      ;; First, undo any WITHOUT-INTERRUPTS we did so that we don't cause the rehash      ;; to lock out everything else.  But do lock the hash table so someone else      ;; won't access it.  3-24-87, -ab      (with-lock ((hash-table-lock hash-table))(let ((inhibit-scheduling-flag previous-inhibit-scheduling-flag))  (funcall (hash-table-rehash-function hash-table) hash-table ())))                      (return (gethash key hash-table)))                     (t (return default-value () ()))))))));;PHD 2/16/87 Fix a bug in the recursive calls.(defun puthash (key value hash-table &rest additional-values )  "Set the values associated with KEY in HASH-TABLE.The first value is set from VALUE.  If the hash table associates morethan one value with each key, the remaining values are set from ADDITIONAL-VALUES.Returns: 1) VALUE, 2) the previous value (or NIL), 3) T if KEY already had an entry in the table, 4) a pointer to the list (inside the hash table)    which holds the key and the associated values."  (declare (values value old-value key-found-flag entry-pointer)   (inline hash-table-p))  (CHECK-ARG hash-table hash-table-p "a hash table")  (let*((previous-inhibit-scheduling-flag inhibit-scheduling-flag);save scheduling state -ab(hash-function (hash-table-hash-function hash-table))(compare-function (hash-table-compare-function hash-table))(values-left (cons value additional-values ))(hash-code (if hash-function (funcall hash-function key) key))(modulus (hash-table-modulus hash-table)))    (with-lock-fast ((hash-table-lock hash-table))      (setq hash-table (follow-structure hash-table))      (do* ((blen (hash-table-block-length hash-table))   (p (hash-block-pointer hash-table hash-code  blen modulus)      (%make-pointer-offset dtp-locative p blen))   (old-value)   (emptyp ()))  (nil);; Make P wrap around at end of table.;; > is used because the pointer-difference, when time to wrap,;; is actually 1 or 2 more than the array length (because it includes the header);;; if BLEN is 2, we could wrap too soon if >= were used.(if (> (%pointer-difference p hash-table) (array-total-size hash-table))    (setq p  (%make-pointer-offset dtp-locative p (- (array-total-size hash-table)))))(cond  ((and (%p-contents-eq p hash-code);Found existing entry(or (null hash-function)    (funcall compare-function (%p-contents-offset p 1) key)))   (let ((value-index (if hash-function 2 1)))     (setq old-value (%p-contents-offset p value-index))     (do ((i value-index (1+ i))) ((= i blen))       (%p-store-contents-offset (pop values-left) p i))     (return value old-value t     (%make-pointer-offset dtp-list p (1- value-index)))))  ((= (%p-data-type p) dtp-null)   (or emptyp (setq emptyp p))   (when (zerop (%p-pointer p))     (cond       ((rehash-for-gc hash-table);; Some %POINTER's may have changed, try rehashing;; First, undo any WITHOUT-INTERRUPTS we did so that we don't cause the rehash;; to lock out everything else.  But do lock the hash table so someone else;; won't access it.  3-24-87, -ab(with-lock ((hash-table-lock hash-table))(let ((inhibit-scheduling-flag previous-inhibit-scheduling-flag))  (funcall (hash-table-rehash-function hash-table) hash-table ())))(return (apply #'puthash key value hash-table additional-values )))       ;; Also, if we are nearly full, rehash in a larger array.       ;; Don't allow the hash table to become full.              ((>=  (+ (hash-table-fullness hash-table)     (hash-table-number-of-deleted-entries hash-table))  (floor    (*      (if (floatp (hash-table-rehash-threshold hash-table))  (hash-table-rehash-threshold hash-table) 0.7s0)      (- modulus 2))));; First, undo any WITHOUT-INTERRUPTS we did so that we don't cause the rehash;; to lock out everything else.  But do lock the hash table so someone else;; won't access it.  3-24-87, -ab(with-lock ((hash-table-lock hash-table))  (let ((inhibit-scheduling-flag previous-inhibit-scheduling-flag))    (funcall (hash-table-rehash-function hash-table)     hash-table      (hash-table-rehash-size hash-table))))(return (apply #'puthash key value hash-table additional-values )))       (t;Add to table using empty slot found(%p-store-contents emptyp hash-code)(cond  (hash-function (%p-store-contents-offset key emptyp 1) (do ((i 2 (1+ i)))     ((= i blen))   (%p-store-contents-offset (pop values-left) emptyp i)))  (t   (do ((i 1 (1+ i)))       ((= i blen))     (%p-store-contents-offset (pop values-left) emptyp i))))(incf (hash-table-fullness hash-table));; If reusing a deleted slot, decrement number of them slots.(or (eq emptyp p)    (decf (hash-table-number-of-deleted-entries hash-table)))(return value))))))))));Used by SETF of GETHASH.(defun sethash (key hash-table value)  (puthash key value hash-table)) ;;; 9/23/86 rla for phd - changed following call to PUTHASH to use APPLY(defun swaphash (key value hash-table &rest additional-values)  "Set the values associated with KEY in HASH-TABLE, returning the previous values.The first value is set to VALUE.  If the hash table holds more than onevalue per entry, the additional values are set from ADDITIONAL-VALUES.The values returned by SWAPHASH are the same as those of GETHASH."  (declare (values old-value old-value-p location))  (multiple-value-bind (nil old-value old-value-p location)      (apply #'puthash  key value hash-table additional-values)    (values old-value old-value-p location)))(defun modifyhash (key hash-table function &rest additional-args &aux new-value)  (multiple-value-bind (value key-found-p values-list) (gethash key hash-table)    (setq new-value (apply function key value key-found-p additional-args));    (unless (and key-found-p (eq new-value value));      (puthash key new-value hash-table))     (if key-found-p (setf (cadr values-list) new-value) (puthash key new-value hash-table))    new-value))(defun remhash (key hash-table )  "Delete any entry for KEY in HASH-TABLE.  Return T if there was one."  (CHECK-ARG hash-table hash-table-p "a hash table")  (let*((previous-inhibit-scheduling-flag inhibit-scheduling-flag);save scheduling state -ab(compare-function (hash-table-compare-function hash-table))(hash-function (hash-table-hash-function hash-table))(hash-code (if hash-function (funcall hash-function key) key)))    (with-lock ((hash-table-lock hash-table))      (without-interrupts(setq hash-table (follow-structure hash-table))(do* ((blen (hash-table-block-length hash-table))      (p (hash-block-pointer hash-table hash-code  blen     (hash-table-modulus hash-table)) (%make-pointer-offset dtp-locative p blen)))     (nil);; Make P wrap around at end of table.  ;; > is used because the pointer-difference, when time to wrap,  ;; is actually 1 or 2 more than the array length (because it includes the header);  ;; if BLEN is 2, we could wrap too soon if >= were used.    (when (> (%pointer-difference p hash-table) (array-total-size hash-table))    (setq p (%make-pointer-offset dtp-locative p (- (array-total-size hash-table)))))  (when (and (%p-contents-eq p hash-code);Found existing entry     (or (null hash-function) (funcall compare-function (%p-contents-offset p 1) key)))    (do ((i 1 (1+ i)))((= i blen))      (%p-store-contents-offset () p i));Wipe out old values        (%P-STORE-DATA-TYPE-AND-POINTER p dtp-null 1);; TGC     (%p-store-data-type p dtp-null) (%p-store-pointer p 1);Remove entry        (decf (hash-table-fullness hash-table))    (incf (hash-table-number-of-deleted-entries hash-table))        ;; Get pointer to the next entry    (let ((next (%make-pointer-offset dtp-locative p blen)))      (when (> (%pointer-difference next hash-table) (array-total-size hash-table))(setq next (%make-pointer-offset dtp-locative next (- (array-total-size hash-table)))))            ;; If the next entry is free, then free up the deleted entries behind it.      (when (and (= (%p-data-type next) dtp-null) (zerop (%p-pointer next)))(do ((prev p (%pointer-difference prev blen)))    (nil)  (when (minusp (%pointer-difference prev hash-table)) ;; Wrap around to the end    (setq prev (%pointer-plus prev (array-total-size hash-table))))  (when (or (/= (%p-data-type prev) dtp-null) (zerop (%p-pointer prev)))    (return));quit when entry not deleted  (%p-store-pointer prev 0);Free deleted entry  (DECF (hash-table-number-of-deleted-entries hash-table)))))    (return t))    (when (and (= (%p-data-type p) dtp-null) (zerop (%p-pointer p)))    (return      (cond((rehash-for-gc hash-table) ;; Some %POINTER's may have changed, try rehashing;; First, undo any WITHOUT-INTERRUPTS we did so that we don't cause the rehash;; to lock out everything else.  But do lock the hash table so someone else;; won't access it.  3-24-87, -ab (with-lock ((hash-table-lock hash-table))   (let ((inhibit-scheduling-flag previous-inhibit-scheduling-flag))     (funcall (hash-table-rehash-function hash-table) hash-table ()))) (remhash key hash-table))(t nil)))))))))(defun maphash (function hash-table &rest extra-args)  "Apply FUNCTION to each item in HASH-TABLE; ignore values.FUNCTION's arguments are the key followed by the values associated with it, followed by the EXTRA-ARGS."  (CHECK-ARG hash-table hash-table-p "a hash table")  (with-lock ((hash-table-lock hash-table))    ;; 3-24-87, -ab.  Put re-hash inside the WITH-LOCK.    (when (rehash-for-gc hash-table)            ;; Some %POINTER's may have changed, try rehashing      (funcall (hash-table-rehash-function hash-table) hash-table ()))    (setq hash-table (follow-structure hash-table))    (let* ((blen (hash-table-block-length hash-table))   (block-offset (if (hash-table-hash-function hash-table) 1 0))   (argcount (- (+ blen (Length extra-args)) block-offset)))      (%assure-PDL-room argcount)      (do(  (i 0 (+ i blen))  (n (array-total-size hash-table))) ((>= i n))(unless (without-interrupts (= (%p-data-type (aloc hash-table i)) dtp-null))  (without-interrupts (%spread (%make-pointer-offset dtp-list (aloc hash-table i) block-offset)))  (%spread extra-args)  (%call function argcount))))    hash-table))(defun maphash-return (function hash-table &optional (return-function 'list)       &aux values )  "Apply FUNCTION to each item in HASH-TABLE; apply RETURN-FUNCTION to list of results.FUNCTION's arguments are the key followed by the values associated with it.The values returned by FUNCTION are put in a list.At the end, RETURN-FUNCTION is applied to that list to get the final value."  (CHECK-ARG hash-table hash-table-p "a hash table")  (with-lock ((hash-table-lock hash-table))    ;; 3-24-87, -ab.  Put re-hash inside the WITH-LOCK.    (when (rehash-for-gc hash-table)      ;; Some %POINTER's may have changed, try rehashing      (funcall (hash-table-rehash-function hash-table) hash-table ()))    (setq hash-table (follow-structure hash-table))    (do ((blen (hash-table-block-length hash-table)) (block-offset (if (hash-table-hash-function hash-table) 1 0)) (i 0 (+ i blen)) (n (array-total-size hash-table)))((>= i n))      (cond((without-interrupts (/=(%p-data-type (aloc hash-table i)) dtp-null)) (let ((value (apply function(without-interrupts (%make-pointer-offset dtp-list (aloc hash-table i) block-offset)))))   (case return-function     (nconc (setq values (nconc value values)))     (t (push value values)))))))    (if (member return-function '(list nconc) :test #'eq) values(apply return-function values))))* :tyo #\+))  (COND    ((AND colon-flag (INTEGERP arg))     (WHEN (MINUSP arg)        (WRITE-CHAR #\- *standard-output*)        (SETQ arg (- arg)))     (IF (ZEROP arg) (WRITE-CHAR #\0 *standard-output*) ;; else make a string of length = number-of-digits + number-of-commas ;; wher