diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index da978c39f16f2936a28d9d8bc5dc71d66338ea8e..258f4d777412e078c155a1869018fe8d75fe58d4 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.78 1998/02/11 06:06:16 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.79 1998/02/13 17:15:08 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1376,6 +1376,7 @@
 ) ;end progn
 
 
+#-propagate-fun-type
 (defoptimizer (ash derive-type) ((n shift))
   (or (let ((n-type (continuation-type n)))
 	(when (numeric-type-p n-type)
@@ -1384,12 +1385,7 @@
 	    (if (constant-continuation-p shift)
 		(let ((shift (continuation-value shift)))
 		  (make-numeric-type :class 'integer  :complexp :real
-				     :low (when n-low
-					    #+new-compiler
-					    (ash n-low shift)
-					    ;; ### fuckin' bignum bug.
-					    #-new-compiler
-					    (* n-low (ash 1 shift)))
+				     :low (when n-low (ash n-low shift))
 				     :high (when n-high (ash n-high shift))))
 		(let ((s-type (continuation-type shift)))
 		  (when (numeric-type-p s-type)
@@ -1407,6 +1403,30 @@
 					     :complexp :real)))))))))
       *universal-type*))
 
+#+propagate-fun-type
+(defun ash-derive-type-aux (n-type shift same-arg)
+  (declare (ignore same-arg))
+  (or (and (csubtypep n-type (specifier-type 'integer))
+	   (csubtypep shift (specifier-type 'integer))
+	   (let ((n-low (numeric-type-low n-type))
+		 (n-high (numeric-type-high n-type))
+		 (s-low (numeric-type-low shift))
+		 (s-high (numeric-type-high shift)))
+	     (if (and s-low s-high (<= s-low 32) (<= s-high 32))
+		 (make-numeric-type :class 'integer  :complexp :real
+				    :low (when n-low
+					   (min (ash n-low s-high)
+						(ash n-low s-low)))
+				    :high (when n-high
+					    (max (ash n-high s-high)
+						 (ash n-high s-low))))
+		 (make-numeric-type :class 'integer
+				    :complexp :real))))
+      *universal-type*))
+
+#+propagate-fun-type
+(defoptimizer (ash derive-type) ((n shift))
+  (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
 
 #-propagate-float-type
 (macrolet ((frob (fun)
@@ -2154,8 +2174,6 @@
 		     0
 		     '*))))
 
-
-
 (defoptimizer (random derive-type) ((bound &optional state))
   (let ((type (continuation-type bound)))
     (when (numeric-type-p type)
@@ -2191,6 +2209,8 @@
 		(or (null min) (minusp min))))
       (values nil t t)))
 
+#-propagate-fun-type
+(progn
 (defoptimizer (logand derive-type) ((x y))
   (multiple-value-bind
       (x-len x-pos x-neg)
@@ -2306,6 +2326,141 @@
        (t
 	(specifier-type 'integer))))))
 
+) ; end progn
+
+#+propagate-fun-type
+(progn
+(defun logand-derive-type-aux (x y &optional same-leaf)
+  (declare (ignore same-leaf))
+  (multiple-value-bind
+      (x-len x-pos x-neg)
+      (integer-type-length x)
+    (declare (ignore x-pos))
+    (multiple-value-bind
+	(y-len y-pos y-neg)
+	(integer-type-length  y)
+      (declare (ignore y-pos))
+      (if (not x-neg)
+	  ;; X must be positive.
+	  (if (not y-neg)
+	      ;; The must both be 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)))
+		    (t
+		     (specifier-type `(unsigned-byte ,(min x-len y-len)))))
+	      ;; X is positive, but Y might be negative.
+	      (cond ((null x-len)
+		     (specifier-type 'unsigned-byte))
+		    ((zerop x-len)
+		     (specifier-type '(integer 0 0)))
+		    (t
+		     (specifier-type `(unsigned-byte ,x-len)))))
+	  ;; X might be negative.
+	  (if (not y-neg)
+	      ;; Y must be positive.
+	      (cond ((null y-len)
+		     (specifier-type 'unsigned-byte))
+		    ((zerop y-len)
+		     (specifier-type '(integer 0 0)))
+		    (t
+		     (specifier-type
+		      `(unsigned-byte ,y-len))))
+	      ;; Either might be negative.
+	      (if (and x-len y-len)
+		  ;; The result is bounded.
+		  (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
+		  ;; We can't tell squat about the result.
+		  (specifier-type 'integer)))))))
+
+(defun logior-derive-type-aux (x y &optional same-leaf)
+  (declare (ignore same-leaf))
+  (multiple-value-bind
+      (x-len x-pos x-neg)
+      (integer-type-length x)
+    (multiple-value-bind
+	(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))))))))
+
+(defun logxor-derive-type-aux (x y &optional same-leaf)
+  (declare (ignore same-leaf))
+  (multiple-value-bind
+      (x-len x-pos x-neg)
+      (integer-type-length x)
+    (multiple-value-bind
+	(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)
+					     '*)))))
+       ((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
+	;; will be negative.
+	(specifier-type `(integer ,(if (and x-len y-len)
+				       (ash -1 (max x-len y-len))
+				       '*)
+				  -1)))
+       ;; We can't tell what the sign of the result is going to be.  All we
+       ;; know is that we don't create new bits.
+       ((and x-len y-len)
+	(specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
+       (t
+	(specifier-type 'integer))))))
+
+(macrolet ((frob (logfcn)
+	     (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX")))
+	     `(defoptimizer (,logfcn derive-type) ((x y))
+	        (two-arg-derive-type x y #',fcn-aux #',logfcn)))))
+  (frob logand)
+  (frob logior)
+  (frob logxor))
+
+) ; end progn
 
 
 ;;;; Miscellaneous derive-type methods: