1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(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) 1986-1989 Texas Instruments Incorporated. All rights reserved.*

(eval-when (compile)
  (DEFMACRO RANDOM-OBJECT-HANDLING (X)
    `(LET* ((Z (%POINTER ,X))
	    (Y (LOGXOR (LDB (- %%Q-POINTER 24.) Z)
		       (LSH Z (- 24. %%Q-POINTER)))))
       (LOGAND #o37777777
	       (IF (MINUSP Z) (LOGXOR Y 1) Y))))
  )

;;12/10/87 CLM for PHD - added handling for complex numbers and ratios. (spr 6738)
(DEFUN SXHASH (X &OPTIONAL RANDOM-OBJECT-ACTION)
  1"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
/(with one arg, passed along from RANDOM-OBJECT-ACTION) to compute their hash codes.
If RANDOM-OBJECT-ACTION is non-NIL, the ultimate default is to use the
object's address to compute a hash code.  This only happens for
objects which cannot be EQUAL unless they are EQ.*"

;;;1If RANDOM-OBJECT-ACTION is NIL, the hash code of an object does not*
;;;1change even if it is printed out and read into a different system version.* ;; dass ist nicht wahr

  ;;;phd 11/18/85 Fixed bad code in sxhash
  ;;;DNG 11/17/86 Special handling for DISPLACED forms.
  (DECLARE (OPTIMIZE SPEED))
  (TYPECASE X
    (SYMBOL (%SXHASH-STRING (SYMBOL-NAME X) #o337))
    (STRING (%SXHASH-STRING X #o337))
    ((OR INTEGER CHARACTER) 
     (IF (MINUSP X) (LOGXOR (LDB 24. X) 1) (LDB 24. X)))
    (LIST
     (IF (AND (EQ (CAR X) 'DISPLACED)
	      (CONSP (SECOND X))
	      (= (LENGTH X) 3)) ; displaced macro, look at original form only.
	 (SXHASH (SECOND X) RANDOM-OBJECT-ACTION)
     ;1;Rotate car by 11. and cdr by 7, but do it efficiently*
     (DO ((ROT 4) 
	  (HASH 0) 
	  Y 
	  (Z X))
	 ((ATOM Z)
	  (UNLESS (NULL Z)
	    (SETQ HASH 
		  (LOGXOR (ROT (SXHASH Z RANDOM-OBJECT-ACTION) (- ROT 4))
			  HASH)))
	  (LOGAND #o37777777 
		  (IF (LDB-TEST (BYTE 1 24.) HASH) 
		      (LOGXOR HASH 1) 
		      HASH)))
       (SETQ Y (POP Z))
       (OR (< (SETQ ROT (+ ROT 7)) 25.) (SETQ ROT (- ROT 25.)))
       (SETQ HASH 
	     (LOGXOR (ROT
		       (TYPECASE Y
			 (SYMBOL (%SXHASH-STRING (SYMBOL-NAME Y) #o337))
			 (STRING (%SXHASH-STRING Y #o337))
			 ((OR fixnum CHARACTER) (si:%pointer  Y))
			 (integer (%logDPB (IF (minusp y) 1 0)
					   %%Q-BOXED-SIGN-BIT  (ldb 24. Y)))
			 (T (SXHASH Y RANDOM-OBJECT-ACTION)))
		       ROT)
		     HASH)))))
    (SINGLE-FLOAT (LOGXOR (%P-LDB-OFFSET #o0030 X 1)
			  (%P-LDB-OFFSET #o3010 X 1)))
    (DOUBLE-FLOAT (LOGXOR (%P-LDB-OFFSET #o0030 X 2)
			  (%P-LDB-OFFSET #o3010 X 2)
			  (%P-LDB-OFFSET #o0030 X 1)
			  (%P-LDB-OFFSET #o3010 X 1)))
    (COMPLEX (SXHASH (* (SYS:COMPLEX-REAL-PART X) (SYS:COMPLEX-IMAG-PART X))))
    (RATIO (SXHASH (* (NUMERATOR X) (DENOMINATOR X))))
    (INSTANCE (OR (SEND X :SEND-IF-HANDLES :SXHASH RANDOM-OBJECT-ACTION) 
		  (AND RANDOM-OBJECT-ACTION (RANDOM-OBJECT-HANDLING X))
		  0))
    (NAMED-STRUCTURE (OR  
		       (AND (MEMBER  :SXHASH (NAMED-STRUCTURE-INVOKE :WHICH-OPERATIONS X) :test #'eq)
			    (NAMED-STRUCTURE-INVOKE :SXHASH X RANDOM-OBJECT-ACTION))
		       (AND RANDOM-OBJECT-ACTION (RANDOM-OBJECT-HANDLING X))
		       (LENGTH X)))
    (ARRAY (LENGTH X))
    (T (IF (OR RANDOM-OBJECT-ACTION (SMALL-FLOATP X)) 
	   (RANDOM-OBJECT-HANDLING X)
	   0 					;0 for things that can't be read
	   ))))