;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.256
;;; Reason:
;;;  EQL hash-tables didn't work for keys that were in fact EQL but not EQ --
;;;  e.g. extended numbers.
;;; Written 5-May-88 13:28:01 by pld at site Gigamos Cambridge
;;; while running on Azathoth from band 3
;;; with Experimental System 123.255, Experimental Local-File 73.5, Experimental FILE-Server 22.4, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, Experimental Tape 22.4, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From file DJ: L.SYS2; HASHFL.LISP#74 at 5-May-88 13:28:01
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; HASHFL  "

(defun eql-hash (key)
  ;;Only fixnums are comparable with eq -- which hash-keys must be.  Do special work for
  ;;various kinds of extended numbers.  Code stolen from sxhash.....
  (values (cond ((fixnump key)
		 key)
		((or (integerp key) (characterp key))
		 (if (minusp key)
		     (logxor (ldb (byte 23. 0) key) 1)
		   (ldb (byte 23. 0) key)))
		((typep key 'single-float)
		 (logxor (%p-ldb-offset (byte 23. 0) key 1)
			 (%p-ldb-offset (byte 1 23.) key 1)
			 (%p-ldb (byte 18. 0) key)))
		((typep key 'short-float)
		 (setq key (%pointer key))
		 (let ((y (logxor (ldb (- %%q-pointer 24.) key)
				  (lsh key (- 24. %%q-pointer)))))
		   (logand #o37777777
			   (if (minusp key) (logxor y 1) y))))
		((numberp key)
		 ;;rational, complex, ... punt
		 0)
		(t
		 key))
	  most-negative-fixnum))

))

; From file DJ: L.SYS2; HASHFL.LISP#74 at 5-May-88 13:29:53
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; HASHFL  "

(defflavor eql-hash-table (kludge-instance-variable) (basic-hash-table)
  (:documentation "Hashing is done with :test eql"))
(defmethod (eql-hash-table :before :init) (plist)
  (setf (get plist :hash-function) #'eql-hash
	(get plist :compare-function) #'eql))
(define-hash-table-methods eql-hash-table
  :hash-code-form (eql-hash key)
  :compare-form (and (eq (contents p) hash-code)
		     (eql key (%p-contents-offset p 1)))
  :rehash-if-lose-form (and (%pointerp key) (hash-array-gc-rehash-necessary-p harry))
  :pre-store-form (when (%pointerp key)
		    (let ((volatility (%pointer-volatility key)))
		      (when (> volatility (hash-array-maximum-key-volatility harry))
			(setf (hash-array-maximum-key-volatility harry) volatility)))))

(compile-flavor-methods eql-hash-table)

))