;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.129
;;; Reason:
;;;  BYTE-specify SXHASH.
;;; Written 23-Oct-88 19:36:43 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Johannes Brahms from band 1
;;; with Experimental System 126.123, Experimental ZWEI 126.21, Experimental ZMail 74.9, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, 10/17.

; From modified file DJ: L.SYS; QRAND.LISP#513 at 23-Oct-88 19:37:00
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QRAND  "

(DEFUN SXHASH (X &OPTIONAL RANDOM-OBJECT-ACTION)
  "Return a hash code for object X.  EQUAL objects have the same hash code.
The hash code is always a positive fixnum.
Flavor instances and named structures may handle the :SXHASH operation.
The hash code of an object does not change even if it is printed out and read
into a different system version."
  (DECLARE (IGNORE RANDOM-OBJECT-ACTION))
  (MACROLET ((ROT-24-BIT (VALUE BITS)
	       (ONCE-ONLY (VALUE BITS)
		 `(DPB ,VALUE (BYTE (- 24. ,BITS) ,BITS)
		       (LSH ,VALUE (- ,BITS 24.))))))
    (COND ((SYMBOLP X) (%SXHASH-STRING (SYMBOL-NAME X) #o337))
	  ((STRINGP X) (%SXHASH-STRING X #o337))	;Ignores case!
	  ((OR (INTEGERP X) (CHARACTERP X))
	   (IF (MINUSP X) (LOGXOR (LDB (BYTE 23. 0.) X) 1) (LDB (BYTE 23. 0.) X)))
	  ((CONSP X)		;Rotate car by 11. and cdr by 7, but do it efficiently
	   (DO ((ROT 4) (HASH 0) Y (X X))
	       ((ATOM X)
		(OR (NULL X)
		    (SETQ HASH (LOGXOR (ROT-24-BIT (SXHASH X)
						   (IF (< ROT 4) (+ ROT 20.) (- ROT 4)))
				       HASH)))
		(LOGAND #o37777777 (IF (LDB-TEST (BYTE 1 23.) HASH) (LOGXOR HASH 1) HASH)))
	     (SETQ Y (CAR X) X (CDR X))
	     (UNLESS (< (SETQ ROT (+ ROT 7)) 24.)
	       (SETQ ROT (- ROT 24.)))
	     (SETQ HASH (LOGXOR (ROT-24-BIT
				  (COND ((SYMBOLP Y) (%SXHASH-STRING (SYMBOL-NAME Y) #o337))
					((STRINGP Y) (%SXHASH-STRING Y #o337))
					((OR (INTEGERP Y) (CHARACTERP Y))
					 (LDB (BYTE 24. 0.) Y))
					(T (SXHASH Y)))
				  ROT)
				HASH))))
	  ((TYPEP X 'SINGLE-FLOAT)
	   (LOGXOR (%P-LDB-OFFSET (BYTE 23. 0.) X 1)
		   (%P-LDB-OFFSET (BYTE 1. 23.) X 1)
		   (%P-LDB (BYTE 18. 0.) X)))
	  ((AND (TYPEP X 'INSTANCE)
		(SEND-IF-HANDLES X :SXHASH NIL)))
	  ((AND (TYPEP X 'NAMED-STRUCTURE)
		(MEMQ ':SXHASH (NAMED-STRUCTURE-INVOKE :WHICH-OPERATIONS X)))
	   (NAMED-STRUCTURE-INVOKE :SXHASH X NIL))
	  ((TYPEP X 'SHORT-FLOAT)
	   (SETQ X (%POINTER X))
	   (LET ((Y (LOGXOR (LDB (byte (- %%Q-POINTER 24.) 0) X)
			    (LSH X (- 24. %%Q-POINTER)))))
	     (LOGAND #o37777777
		     (IF (MINUSP X) (LOGXOR Y 1) Y))))
	  ((ARRAYP X)
	   (LENGTH X))
	  (T 0))))					;0 for random things

))