diff --git a/code/float.lisp b/code/float.lisp
index 5780aa86284363d7c32d44f3446c130e00567e3f..5d2c2cf83f5edf6aec04cb135b14403150504d91 100644
--- a/code/float.lisp
+++ b/code/float.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/code/float.lisp,v 1.24 2001/06/17 19:08:35 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.25 2002/02/25 16:23:10 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -17,7 +17,8 @@
 ;;; Long-float support by Douglas Crosher, 1998.
 ;;; 
 (in-package "KERNEL")
-(export '(%unary-truncate %unary-round))
+(export '(%unary-truncate %unary-round %unary-ftruncate
+	  %unary-ftruncate/single-float %unary-ftruncate/double-float))
 
 (in-package "LISP")
 (export '(least-positive-normalized-short-float
@@ -1061,6 +1062,117 @@ rounding modes & do ieee round-to-integer.
 	     (if (minusp number)
 		 (- rounded)
 		 rounded)))))))
+
+;; %UNARY-FTRUNCATE/SINGLE-FLOAT
+;;
+;; Basically the same as ftruncate, but specialized to handle only
+;; single-floats and to only return the first value.  We diddle the
+;; bits directly to truncate the number to reduce consing.
+(defun %unary-ftruncate/single-float (x)
+  (declare (single-float x)
+	   (optimize (speed 3) (safety 0)))
+  (let* ((bits (kernel:single-float-bits x))
+	 (exp (ldb vm:single-float-exponent-byte bits))
+	 (biased (truly-the kernel:single-float-exponent
+			    (- exp vm:single-float-bias))))
+    (cond ((= exp vm:single-float-normal-exponent-max)
+	   ;; Infinity or NaN.
+	   x)
+	  (t
+	   ;; At this point, we have the number represented as
+	   ;;
+	   ;; x = sign * 2^exp * frac
+	   ;;
+	   ;; where 0.5 <= frac < 1.0
+	   ;;
+	   ;; So if the exp <= 0, |x| < 1 and we know the result is 0.
+	   ;;
+	   ;; If exp >= (float-digits x), we know that all of the bits
+	   ;; in the fraction are integer bits, so the result is x.
+	   ;;
+	   ;; For everything else, some of the bits in frac are
+	   ;; fractional.  Figure which ones they are and set them to
+	   ;; zero.
+	   (cond ((<= biased 0)
+		  ;; Number is less than 1
+		  0f0)
+		 ((>= biased (float-digits x))
+		  ;; Number is an integer
+		  x)
+		 (t
+		  ;; Somewhere in between.  Zap the bits that
+		  ;; represent the fraction part.
+		  (let ((frac-bits (- (float-digits x) biased)))
+		    (declare (type (signed-byte 32) bits))
+		    (setf bits (logandc2 bits (- (ash 1 frac-bits) 1)))
+		    (kernel:make-single-float bits))))))))
+
+;; %UNARY-FTRUNCATE/DOUBLE-FLOAT
+;;
+;; Like %UNARY-FTRUNCATE/SINGLE-FLOAT, except for double-float.
+
+(defun %unary-ftruncate/double-float (x)
+  (declare (double-float x)
+	   (optimize (speed 3) (safety 0)))
+  (let* ((hi (kernel:double-float-high-bits x))
+	 (lo (kernel:double-float-low-bits x))
+	 (exp (ldb vm:double-float-exponent-byte hi))
+	 (biased (truly-the kernel:double-float-exponent
+			    (- exp vm:double-float-bias))))
+    (declare (type (signed-byte 32) hi)
+	     (type (unsigned-byte 32) lo))
+    (cond ((= exp vm:double-float-normal-exponent-max)
+	   x)
+	  ((< biased 0)
+	   ;; Number is less than 1
+	   0d0)
+	  ((>= biased (float-digits x))
+	   ;; Number is an integer
+	   x)
+	  (t
+	   ;; Somewhere in between.  Zap the bits that
+	   ;; represent the fraction part.
+	   (let ((frac-bits (- (float-digits x) biased)))
+	     (cond ((< frac-bits 32)
+		    (setf lo (logandc2 lo (- (ash 1 frac-bits) 1))))
+		   (t
+		    (setf lo 0)
+		    (setf hi (logandc2 hi (- (ash 1 (- frac-bits 32)) 1)))))
+	     (kernel:make-double-float hi lo))))))
+
+
+;;; %UNARY-FTRUNCATE  --  Interface
+;;;
+;;; This function is called when we are doing an ftruncate without any
+;;; funky divisor.  Note that we do *not* return the second value of
+;;; truncate, so it must be computed by the caller if needed.
+;;;
+;;; In the float case, we pick off small arguments so that compiler
+;;; can use special-case operations.  We use an exclusive test, since
+;;; (due to round-off error), (float most-positive-signed-byte-32) may
+;;; be greater than most-positive-signed-byte-32.  We chose this
+;;; because %unary-truncate can be optimized when the result is known
+;;; to be a (signed-byte 32).
+;;;
+(defun %unary-ftruncate (number)
+  (macrolet ((truncate-float (rtype helper)
+	       `(if (< (float (- (- (ash 1 31)) 1) number)
+		       number
+		       (float (ash 1 31) number))
+		    (coerce (truly-the (signed-byte 32)
+				       (%unary-truncate number))
+			    ',rtype)
+		    (,helper number))))
+  (number-dispatch ((number real))
+    ((integer)
+     (float number))
+    ((ratio)
+     (float (truncate (numerator number) (denominator number))))
+    ((single-float)
+     (truncate-float single-float %unary-ftruncate/single-float))
+    ((double-float)
+     (truncate-float double-float %unary-ftruncate/double-float)))))
+	     
 
 
 (defun rational (x)
diff --git a/code/numbers.lisp b/code/numbers.lisp
index 8d12b688e261f60a80ce42e462357b36fe1433a3..c747d57ec9da9db77f71f47741763e5a579a30bc 100644
--- a/code/numbers.lisp
+++ b/code/numbers.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/code/numbers.lisp,v 1.39 2001/09/28 14:56:28 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.40 2002/02/25 16:23:10 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -669,7 +669,9 @@
 ;;; maybe-inline for now, so that the power-of-2 ceiling and floor transforms
 ;;; get a chance.
 ;;;
-(declaim (inline rem mod fceiling ffloor ftruncate))
+;;; Don't inline ftruncate because it's probably too big now.
+;;;
+(declaim (inline rem mod fceiling ffloor))
 (declaim (maybe-inline ceiling floor))
 
 ;;; If the numbers do not divide exactly and the result of (/ number divisor)
@@ -742,20 +744,74 @@
 	rem)))
 
 
-(macrolet ((frob (name op doc)
-	     `(defun ,name (number &optional (divisor 1))
-		,doc
-		(multiple-value-bind (res rem) (,op number divisor)
-		  (values (float res (if (floatp rem) rem 1.0)) rem)))))
-  (frob ffloor floor
-    "Same as FLOOR, but returns first value as a float.")
-  (frob fceiling ceiling
-    "Same as CEILING, but returns first value as a float." )
-  (frob ftruncate truncate
-    "Same as TRUNCATE, but returns first value as a float.")
-  (frob fround round
-    "Same as ROUND, but returns first value as a float."))
+(defun ftruncate (number &optional (divisor 1))
+  "Same as TRUNCATE, but returns first value as a float."
+  (macrolet ((truncate-float (rtype)
+	       `(let* ((float-div (coerce divisor ',rtype))
+		       (res (%unary-ftruncate (/ number float-div))))
+		 (values res
+		  (- number
+		   (* (coerce res ',rtype) float-div))))))
+    (number-dispatch ((number real) (divisor real))
+      (((foreach fixnum bignum ratio) (or fixnum bignum ratio))
+       (multiple-value-bind (q r)
+	   (truncate number divisor)
+	 (values (float q) r)))
+      (((foreach single-float double-float)
+	(or rational single-float))
+       (if (eql divisor 1)
+	   (let ((res (%unary-ftruncate number)))
+	     (values res (- number (coerce res '(dispatch-type number)))))
+	   (truncate-float (dispatch-type number))))
+      ((double-float (or single-float double-float))
+       (truncate-float double-float))
+      ((single-float double-float)
+       (truncate-float double-float))
+      (((foreach fixnum bignum ratio)
+	(foreach single-float double-float))
+       (truncate-float (dispatch-type divisor))))))
+
 
+(defun ffloor (number &optional (divisor 1))
+  "Same as FLOOR, but returns first value as a float."
+  (multiple-value-bind (tru rem) (ftruncate number divisor)
+    (if (and (not (zerop rem))
+	     (if (minusp divisor)
+		 (plusp number)
+		 (minusp number)))
+	(values (1- tru) (+ rem divisor))
+	(values tru rem))))
+
+(defun fceiling (number &optional (divisor 1))
+  "Same as CEILING, but returns first value as a float." 
+  (multiple-value-bind (tru rem) (ftruncate number divisor)
+    (if (and (not (zerop rem))
+	     (if (minusp divisor)
+		 (minusp number)
+		 (plusp number)))
+	(values (+ tru 1) (- rem divisor))
+	(values tru rem))))
+
+
+(defun fround (number &optional (divisor 1))
+  "Same as ROUND, but returns first value as a float."
+  (if (eql divisor 1)
+      (round number)
+      (multiple-value-bind (tru rem)
+	  (ftruncate number divisor)
+	(let ((thresh (/ (abs divisor) 2)))
+	  (cond ((or (> rem thresh)
+		     (and (= rem thresh) (oddp tru)))
+		 (if (minusp divisor)
+		     (values (- tru 1) (+ rem divisor))
+		     (values (+ tru 1) (- rem divisor))))
+		((let ((-thresh (- thresh)))
+		   (or (< rem -thresh)
+		       (and (= rem -thresh) (oddp tru))))
+		 (if (minusp divisor)
+		     (values (+ tru 1) (- rem divisor))
+		     (values (- tru 1) (+ rem divisor))))
+		(t (values tru rem)))))))
 
 ;;;; Comparisons:
 
diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index 8d3342777e50742302f191fdf70989d8296d70ff..901f4171a841fd62c07b18d39546111bed3ec7e4 100644
--- a/compiler/float-tran.lisp
+++ b/compiler/float-tran.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/float-tran.lisp,v 1.84 2001/09/24 15:25:38 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.85 2002/02/25 16:23:11 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -92,6 +92,42 @@
 	(values (1+ tru) (- rem divisor))
 	(values tru rem))))
 
+(defknown %unary-ftruncate/single-float (single-float) single-float
+	  (movable foldable flushable))
+(defknown %unary-ftruncate/double-float (double-float) double-float
+	  (movable foldable flushable))
+
+(defknown %unary-ftruncate (float) float
+	  (movable foldable flushable))
+
+;; Convert (ftruncate x y) to the obvious implementation.  We only
+;; want this under certain conditions and let the generic ftruncate
+;; handle the rest.  (Note: if y = 1, the divide and multiply by y
+;; should be removed by other deftransforms.)
+
+(deftransform ftruncate ((x &optional (y 1))
+			(float &optional (or float integer)))
+  '(let ((res (%unary-ftruncate (/ x y))))
+     (values res (- x (* y res)))))
+
+;; Convert %unary-ftruncate to unary-ftruncate/{single,double}-float
+;; if x is known to be of the right type.  Also, if the result is
+;; known to fit in the same range as a (signed-byte 32), convert this
+;; to %unary-truncate, which might be a single instruction, and float
+;; the result.
+
+(macrolet ((frob (ftype func)
+	     `(deftransform %unary-ftruncate ((x) (,ftype))
+		(let* ((x-type (continuation-type x))
+		       (lo (numeric-type-low x-type))
+		       (hi (numeric-type-high x-type)))
+		  (if (and (numberp lo) (numberp hi)
+			   (< (- (ash 1 31)) lo)
+			   (< hi (ash 1 31)))
+		      '(coerce (%unary-truncate x) ',ftype)
+		      '(,func x))))))
+  (frob single-float %unary-ftruncate/single-float)
+  (frob double-float %unary-ftruncate/double-float))
 
 ;;; Random:
 ;;;