diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index a2e0a9055194d2d9a33057516458ee6535ebfc37..9bd3ede2f4bdd2c09070cc4ec6eec8ac7704b76b 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.148 2004/07/15 21:37:22 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.149 2004/07/19 17:54:58 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2233,15 +2233,126 @@
 		(or (null min) (minusp min))))
       (values nil t t)))
 
+;;; From Hacker's Delight, by Henry S. Warren, Jr.
+
+;;; Let a <= x <= b and c <= y <= d, with X and Y both unsigned 32-bit
+;;; numbers.  (Mostly because that's what the routines support, but
+;;; they could be extended to any positive integer.)  MIN-AND and
+;;; MAX-AND compute reasonably tight bounds on x&y.  MIN-OR and MAX-OR
+;;; compute the bounds on x|y.
+
+(defun min-and (a b c d)
+  (let ((m #x80000000))
+    (loop while (not (zerop m))
+       do
+       (when (/= (logand m (lognot a) (lognot c)) 0)
+	 (let ((temp (logandc2 (logior a m) m)))
+	   (when (<= temp b)
+	     (setf a temp)
+	     (return)))
+	 (let ((temp (logandc2 (logior c m) m)))
+	   (when (<= temp d)
+	     (setf c temp)
+	     (return))))
+       (setf m (ash m -1)))
+    (logand a c)))
+
+(defun max-and (a b c d)
+  (let ((m #x80000000))
+    (loop while (not (zerop m))
+       do
+       (cond ((/= (logand b (lognot d) m) 0)
+	      (let ((temp (logior (logandc2 b m) (- m 1))))
+		(when (>= temp a)
+		  (setf b temp)
+		  (return))))
+	     ((/= (logand (lognot b) d m) 0)
+	      (let ((temp (logior (logandc2 d m) (- m 1))))
+		(when (>= temp c)
+		  (setf d temp)
+		  (return)))))
+       (setf m (ash m -1))))
+  (logand b d))
+
+(defun min-or (a b c d)
+  (let ((m #x80000000))
+    (loop while (not (zerop m))
+       do
+       (cond ((/= (logandc2 (logand c m) a) 0)
+	      (let ((temp (logand (logior a m)
+				  (1+ (lognot m)))))
+		(when (<= temp b)
+		  (setf a temp)
+		  (return))))
+	     ((/= (logandc1 c (logand a m)) 0)
+	      (let ((temp (logand (logior c m)
+				  (1+ (lognot m)))))
+		(when (<= temp d)
+		  (setf c temp)
+		  (return)))))
+       (setf m (ash m -1))))
+  (logior a c))
+
+(defun max-or (a b c d)
+  (let ((m #x80000000))
+    (loop while (not (zerop m))
+       do
+       (when (/= (logand m b d) 0)
+	 (let ((temp (logior (- b m)
+			     (- m 1))))
+	   (when (>= temp a)
+	     (setf b temp)
+	     (return)))
+	 (let ((temp (logior (- d m)
+			     (- m 1))))
+	   (when (>= temp c)
+	     (setf d temp)
+	     (return))))
+	 (setf m (ash m -1)))
+    (logior b d)))
+  
+(defun min-xor (a b c d)
+  (let ((m #x80000000))
+    (loop while (not (zerop m))
+       do
+       (cond ((/= (logandc2 (logand c m) a) 0)
+	      (let ((temp (logand (logior a m)
+				  (1+ (lognot m)))))
+		(when (<= temp b)
+		  (setf a temp))))
+	     ((/= (logandc1 c (logand a m)) 0)
+	      (let ((temp (logand (logior c m)
+				  (1+ (lognot m)))))
+		(when (<= temp d)
+		  (setf c temp)))))
+       (setf m (ash m -1))))
+  (logxor a c))
+
+(defun max-xor (a b c d)
+  (let ((m #x80000000))
+    (loop while (not (zerop m))
+       do
+       (when (/= (logand m b d) 0)
+	 (let ((temp (logior (- b m)
+			     (- m 1))))
+	   (if (>= temp a)
+	       (setf b temp)
+	       (let ((temp (logior (- d m)
+				   (- m 1))))
+		 (when (>= temp c)
+		   (setf d temp))))))
+       (setf m (ash m -1)))
+    (logxor b d)))
+  
 
 (defun logand-derive-type-aux (x y &optional same-leaf)
   (declare (ignore same-leaf))
   (multiple-value-bind
-      (x-len x-pos x-neg)
+	(x-len x-pos x-neg)
       (integer-type-length x)
     (declare (ignore x-pos))
     (multiple-value-bind
-	(y-len y-pos y-neg)
+	  (y-len y-pos y-neg)
 	(integer-type-length  y)
       (declare (ignore y-pos))
       (if (not x-neg)
@@ -2252,6 +2363,27 @@
 		     (specifier-type 'unsigned-byte))
 		    ((or (zerop x-len) (zerop y-len))
 		     (specifier-type '(integer 0 0)))
+		    ((and (<= x-len 32) (<= y-len 32))
+		     ;; If both args are unsigned 32-bit numbers, we
+		     ;; can compute better bounds, so we do.  But if
+		     ;; one arg is a constant and is a single bit, we
+		     ;; can do even better.
+		     ;;
+		     ;; What about the case where one arg is constant
+		     ;; and has several bits set?  We could compute
+		     ;; exact values by turning off each individual
+		     ;; bit and all combinations thereof.  Should we?
+		     (let ((xlo (numeric-type-low x))
+			   (xhi (numeric-type-high x))
+			   (ylo (numeric-type-low y))
+			   (yhi (numeric-type-high y)))
+		       (cond ((and (= xlo xhi) (= 1 (logcount xlo)))
+			      (specifier-type `(member 0 ,xlo)))
+			     ((and (= ylo yhi) (= 1 (logcount ylo)))
+			      (specifier-type `(member 0 ,ylo)))
+			     (t
+			      (specifier-type `(integer ,(min-and xlo xhi ylo yhi)
+							,(max-and xlo xhi ylo yhi)))))))
 		    (t
 		     (specifier-type `(unsigned-byte ,(min x-len y-len)))))
 	      ;; X is positive, but Y might be negative.
@@ -2281,47 +2413,54 @@
 (defun logior-derive-type-aux (x y &optional same-leaf)
   (declare (ignore same-leaf))
   (multiple-value-bind
-      (x-len x-pos x-neg)
+	(x-len x-pos x-neg)
       (integer-type-length x)
     (multiple-value-bind
-	(y-len y-pos y-neg)
+	  (y-len y-pos y-neg)
 	(integer-type-length y)
-      (cond
-       ((and (not x-neg) (not y-neg))
-	;; Both are positive.
-	(if (and x-len y-len (zerop x-len) (zerop y-len))
-	    (specifier-type '(integer 0 0))
-	    (specifier-type `(unsigned-byte ,(if (and x-len y-len)
-					     (max x-len y-len)
-					     '*)))))
-       ((not x-pos)
-	;; X must be negative.
-	(if (not y-pos)
-	    ;; Both are negative.  The result is going to be negative and be
-	    ;; the same length or shorter than the smaller.
-	    (if (and x-len y-len)
-		;; It's bounded.
-		(specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
-		;; It's unbounded.
-		(specifier-type '(integer * -1)))
-	    ;; X is negative, but we don't know about Y.  The result will be
-	    ;; negative, but no more negative than X.
-	    (specifier-type
-	     `(integer ,(or (numeric-type-low x) '*)
-		       -1))))
-       (t
-	;; X might be either positive or negative.
-	(if (not y-pos)
-	    ;; But Y is negative.  The result will be negative.
-	    (specifier-type
-	     `(integer ,(or (numeric-type-low y) '*)
-		       -1))
-	    ;; We don't know squat about either.  It won't get any bigger.
-	    (if (and x-len y-len)
-		;; Bounded.
-		(specifier-type `(signed-byte ,(1+ (max x-len y-len))))
-		;; Unbounded.
-		(specifier-type 'integer))))))))
+      (cond ((and (not x-neg) (not y-neg))
+	     ;; Both are positive.
+	     (cond ((or (null x-len) (null y-len))
+		    (specifier-type 'unsigned-byte))
+		   ((or (zerop x-len) (zerop y-len))
+		    (specifier-type '(integer 0 0)))
+		   ((and (<= x-len 32) (<= y-len 32))
+		    (let ((xlo (numeric-type-low x))
+			  (xhi (numeric-type-high x))
+			  (ylo (numeric-type-low y))
+			  (yhi (numeric-type-high y)))
+		      (specifier-type `(integer ,(min-or xlo xhi ylo yhi)
+						,(max-or xlo xhi ylo yhi)))))
+		   (t
+		    (specifier-type `(unsigned-byte ,(max x-len y-len))))))
+	    ((not x-pos)
+	     ;; X must be negative.
+	     (if (not y-pos)
+		 ;; Both are negative.  The result is going to be negative and be
+		 ;; the same length or shorter than the smaller.
+		 (if (and x-len y-len)
+		     ;; It's bounded.
+		     (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
+		     ;; It's unbounded.
+		     (specifier-type '(integer * -1)))
+		 ;; X is negative, but we don't know about Y.  The result will be
+		 ;; negative, but no more negative than X.
+		 (specifier-type
+		  `(integer ,(or (numeric-type-low x) '*)
+			    -1))))
+	    (t
+	     ;; X might be either positive or negative.
+	     (if (not y-pos)
+		 ;; But Y is negative.  The result will be negative.
+		 (specifier-type
+		  `(integer ,(or (numeric-type-low y) '*)
+			    -1))
+		 ;; We don't know squat about either.  It won't get any bigger.
+		 (if (and x-len y-len)
+		     ;; Bounded.
+		     (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
+		     ;; Unbounded.
+		     (specifier-type 'integer))))))))
 
 (defun logxor-derive-type-aux (x y &optional same-leaf)
   (declare (ignore same-leaf))
@@ -2332,15 +2471,29 @@
 	(y-len y-pos y-neg)
 	(integer-type-length y)
       (cond
-       ((or (and (not x-neg) (not y-neg))
-	    (and (not x-pos) (not y-pos)))
-	;; Either both are negative or both are positive.  The result will be
-	;; positive, and as long as the longer.
-	(if (and x-len y-len (zerop x-len) (zerop y-len))
-	    (specifier-type '(integer 0 0))
-	    (specifier-type `(unsigned-byte ,(if (and x-len y-len)
-					     (max x-len y-len)
-					     '*)))))
+	((and (not x-neg) (not y-neg))
+	 ;; Both are positive
+	 (cond ((or (null x-len) (null y-len))
+		(specifier-type 'unsigned-byte))
+	       ((or (zerop x-len) (zerop y-len))
+		(specifier-type '(integer 0 0)))
+	       ((and (<= x-len 32) (<= y-len 32))
+		(let ((xlo (numeric-type-low x))
+		      (xhi (numeric-type-high x))
+		      (ylo (numeric-type-low y))
+		      (yhi (numeric-type-high y)))
+		  (specifier-type `(integer ,(min-xor xlo xhi ylo yhi)
+					    ,(max-xor xlo xhi ylo yhi)))))
+	       (t
+		(specifier-type `(unsigned-byte ,(max x-len y-len))))))
+	((and x-neg y-neg)
+	 ;; Both are negative.  The result will be positive, and as
+	 ;; long as the longer.
+	 (if (and x-len y-len (zerop x-len) (zerop y-len))
+	     (specifier-type '(integer 0 0))
+	     (specifier-type `(unsigned-byte ,(if (and x-len y-len)
+						  (max x-len y-len)
+						  '*)))))	 
        ((or (and (not x-pos) (not y-neg))
 	    (and (not y-neg) (not y-pos)))
 	;; Either X is negative and Y is positive of vice-verca.  The result