diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 979d4b70fdcc092509bdc5fae2d35d486e8c82d1..f0b3648dd46344d70f6591df6cb086388276e25e 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.113 2002/10/07 17:44:12 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.114 2003/03/19 14:24:41 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2678,8 +2678,9 @@
 	(add '(ash x 31))))
     (or result 0)))
 
-;;; If arg is a constant power of two, turn floor into a shift and mask.
-;;; If ceiling, add in (1- (abs y)) and then do floor.
+;;; If arg is a constant power of two, turn floor into a shift and
+;;; mask. If ceiling, add in (1- (abs y)) and do floor, and correct
+;;; the remainder.
 ;;;
 (flet ((frob (y ceil-p)
 	 (unless (constant-continuation-p y) (give-up))
@@ -2688,13 +2689,14 @@
 		(len (1- (integer-length y-abs))))
 	   (unless (= y-abs (ash 1 len)) (give-up))
 	   (let ((shift (- len))
-		 (mask (1- y-abs)))
-	     `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
+		 (mask (1- y-abs))
+                 (delta (if ceil-p (* (signum y) (1- y-abs)) 0)))
+	     `(let ((x (+ x ,delta)))
 		,(if (minusp y)
 		     `(values (ash (- x) ,shift)
-			      (- (logand (- x) ,mask)))
+			      (- (- (logand (- x) ,mask)) ,delta))
 		     `(values (ash x ,shift)
-			      (logand x ,mask))))))))
+			      (- (logand x ,mask) ,delta))))))))
   (deftransform floor ((x y) (integer integer) *)
     "convert division by 2^k to shift"
     (frob y nil))