X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=ec1fabfe9f8aac8c71fc6c06d3f1e3756fdcb41f;hb=bffa99d35c7d50ac46b9eb7dbe25d1ab1a0e6145;hp=bdbc2fefaa44de53f4c8bd622454e99f229725b8;hpb=993d5b779638756473181dda8d928d33038d4cc3;p=sbcl.git

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index bdbc2fe..ec1fabf 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -18,35 +18,27 @@
 (defknown %single-float (real) single-float (movable foldable flushable))
 (defknown %double-float (real) double-float (movable foldable flushable))
 
-(deftransform float ((n &optional f) (* &optional single-float) * :when :both)
+(deftransform float ((n f) (* single-float) *)
   '(%single-float n))
 
-(deftransform float ((n f) (* double-float) * :when :both)
+(deftransform float ((n f) (* double-float) *)
   '(%double-float n))
 
-(deftransform %single-float ((n) (single-float) * :when :both)
-  'n)
+(deftransform float ((n) *)
+  '(if (floatp n)
+       n
+       (%single-float n)))
 
-(deftransform %double-float ((n) (double-float) * :when :both)
+(deftransform %single-float ((n) (single-float) *)
   'n)
 
-;;; not strictly float functions, but primarily useful on floats:
-(macrolet ((frob (fun ufun)
-	     `(progn
-		(defknown ,ufun (real) integer (movable foldable flushable))
-		(deftransform ,fun ((x &optional by)
-				    (* &optional
-				       (constant-argument (member 1))))
-		  '(let ((res (,ufun x)))
-		     (values res (- x res)))))))
-  (frob truncate %unary-truncate)
-  (frob round %unary-round))
+(deftransform %double-float ((n) (double-float) *)
+  'n)
 
 ;;; RANDOM
 (macrolet ((frob (fun type)
 	     `(deftransform random ((num &optional state)
-				    (,type &optional *) *
-				    :when :both)
+				    (,type &optional *) *)
 		"Use inline float operations."
 		'(,fun num (or state *random-state*)))))
   (frob %random-single-float single-float)
@@ -63,11 +55,11 @@
   ;; of automatically finding #!+sb-doc in proximity to DEFTRANSFORM
   ;; to let me scan for places that I made this mistake and didn't
   ;; catch myself.
-  "use inline (unsigned-byte 32) operations"
-  (let ((num-high (numeric-type-high (continuation-type num))))
+  "use inline (UNSIGNED-BYTE 32) operations"
+  (let ((num-high (numeric-type-high (lvar-type num))))
     (when (null num-high)
       (give-up-ir1-transform))
-    (cond ((constant-continuation-p num)
+    (cond ((constant-lvar-p num)
 	   ;; Check the worst case sum absolute error for the random number
 	   ;; expectations.
 	   (let ((rem (rem (expt 2 32) num-high)))
@@ -145,45 +137,75 @@
   (values double-float-significand double-float-int-exponent (integer -1 1))
   (movable foldable flushable))
 
-(defknown scale-single-float (single-float fixnum) single-float
+(defknown scale-single-float (single-float integer) single-float
   (movable foldable flushable))
 
-(defknown scale-double-float (double-float fixnum) double-float
+(defknown scale-double-float (double-float integer) double-float
   (movable foldable flushable))
 
-(deftransform decode-float ((x) (single-float) * :when :both)
+(deftransform decode-float ((x) (single-float) *)
   '(decode-single-float x))
 
-(deftransform decode-float ((x) (double-float) * :when :both)
+(deftransform decode-float ((x) (double-float) *)
   '(decode-double-float x))
 
-(deftransform integer-decode-float ((x) (single-float) * :when :both)
+(deftransform integer-decode-float ((x) (single-float) *)
   '(integer-decode-single-float x))
 
-(deftransform integer-decode-float ((x) (double-float) * :when :both)
+(deftransform integer-decode-float ((x) (double-float) *)
   '(integer-decode-double-float x))
 
-(deftransform scale-float ((f ex) (single-float *) * :when :both)
+(deftransform scale-float ((f ex) (single-float *) *)
   (if (and #!+x86 t #!-x86 nil
-	   (csubtypep (continuation-type ex)
-		      (specifier-type '(signed-byte 32)))
-	   (not (byte-compiling)))
+	   (csubtypep (lvar-type ex)
+		      (specifier-type '(signed-byte 32))))
       '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)
       '(scale-single-float f ex)))
 
-(deftransform scale-float ((f ex) (double-float *) * :when :both)
+(deftransform scale-float ((f ex) (double-float *) *)
   (if (and #!+x86 t #!-x86 nil
-	   (csubtypep (continuation-type ex)
+	   (csubtypep (lvar-type ex)
 		      (specifier-type '(signed-byte 32))))
       '(%scalbn f ex)
       '(scale-double-float f ex)))
 
-;;; toy@rtp.ericsson.se:
+;;; What is the CROSS-FLOAT-INFINITY-KLUDGE?
+;;;
+;;; SBCL's own implementation of floating point supports floating
+;;; point infinities. Some of the old CMU CL :PROPAGATE-FLOAT-TYPE and
+;;; :PROPAGATE-FUN-TYPE code, like the DEFOPTIMIZERs below, uses this
+;;; floating point support. Thus, we have to avoid running it on the
+;;; cross-compilation host, since we're not guaranteed that the
+;;; cross-compilation host will support floating point infinities.
 ;;;
+;;; If we wanted to live dangerously, we could conditionalize the code
+;;; with #+(OR SBCL SB-XC) instead. That way, if the cross-compilation
+;;; host happened to be SBCL, we'd be able to run the infinity-using
+;;; code. Pro:
+;;;   * SBCL itself gets built with more complete optimization.
+;;; Con:
+;;;   * You get a different SBCL depending on what your cross-compilation
+;;;     host is.
+;;; So far the pros and cons seem seem to be mostly academic, since
+;;; AFAIK (WHN 2001-08-28) the propagate-foo-type optimizations aren't
+;;; actually important in compiling SBCL itself. If this changes, then
+;;; we have to decide:
+;;;   * Go for simplicity, leaving things as they are.
+;;;   * Go for performance at the expense of conceptual clarity,
+;;;     using #+(OR SBCL SB-XC) and otherwise leaving the build
+;;;     process as is.
+;;;   * Go for performance at the expense of build time, using
+;;;     #+(OR SBCL SB-XC) and also making SBCL do not just
+;;;     make-host-1.sh and make-host-2.sh, but a third step
+;;;     make-host-3.sh where it builds itself under itself. (Such a
+;;;     3-step build process could also help with other things, e.g.
+;;;     using specialized arrays to represent debug information.)
+;;;   * Rewrite the code so that it doesn't depend on unportable
+;;;     floating point infinities.
+
 ;;; optimizers for SCALE-FLOAT. If the float has bounds, new bounds
 ;;; are computed for the result, if possible.
-
-#!+propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 
 (defun scale-float-derive-type-aux (f ex same-arg)
@@ -194,7 +216,7 @@
 	   ;; zeros.
 	   (set-bound
 	    (handler-case
-	     (scale-float (bound-value x) n)
+	     (scale-float (type-bound-number x) n)
 	     (floating-point-overflow ()
 		nil))
 	    (consp x))))
@@ -221,13 +243,10 @@
   (two-arg-derive-type f ex #'scale-float-derive-type-aux
 		       #'scale-double-float t))
 
-;;; toy@rtp.ericsson.se:
-;;;
-;;; Defoptimizers for %single-float and %double-float. This makes the
+;;; DEFOPTIMIZERs for %SINGLE-FLOAT and %DOUBLE-FLOAT. This makes the
 ;;; FLOAT function return the correct ranges if the input has some
 ;;; defined range. Quite useful if we want to convert some type of
 ;;; bounded integer into a float.
-
 (macrolet
     ((frob (fun type)
        (let ((aux-name (symbolicate fun "-DERIVE-TYPE-AUX")))
@@ -235,11 +254,11 @@
 	   (defun ,aux-name (num)
 	     ;; When converting a number to a float, the limits are
 	     ;; the same.
-	     (let* ((lo (bound-func #'(lambda (x)
-					(coerce x ',type))
+	     (let* ((lo (bound-func (lambda (x)
+				      (coerce x ',type))
 				    (numeric-type-low num)))
-		    (hi (bound-func #'(lambda (x)
-					(coerce x ',type))
+		    (hi (bound-func (lambda (x)
+				      (coerce x ',type))
 				    (numeric-type-high num))))
 	       (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
 
@@ -253,12 +272,12 @@
 
 ;;; Do some stuff to recognize when the loser is doing mixed float and
 ;;; rational arithmetic, or different float types, and fix it up. If
-;;; we don't, he won't even get so much as an efficency note.
+;;; we don't, he won't even get so much as an efficiency note.
 (deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node)
-  `(,(continuation-function-name (basic-combination-fun node))
+  `(,(lvar-fun-name (basic-combination-fun node))
     (float x y) y))
 (deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
-  `(,(continuation-function-name (basic-combination-fun node))
+  `(,(lvar-fun-name (basic-combination-fun node))
     x (float y x)))
 
 (dolist (x '(+ * / -))
@@ -277,11 +296,12 @@
 ;;; do it for any rational that has a precise representation as a
 ;;; float (such as 0).
 (macrolet ((frob (op)
-	     `(deftransform ,op ((x y) (float rational) * :when :both)
-		(unless (constant-continuation-p y)
+	     `(deftransform ,op ((x y) (float rational) *)
+		"open-code FLOAT to RATIONAL comparison"
+		(unless (constant-lvar-p y)
 		  (give-up-ir1-transform
-		   "can't open-code float to rational comparison"))
-		(let ((val (continuation-value y)))
+		   "The RATIONAL value isn't known at compile time."))
+		(let ((val (lvar-value y)))
 		  (unless (eql (rational (float val)) val)
 		    (give-up-ir1-transform
 		     "~S doesn't have a precise float representation."
@@ -295,7 +315,7 @@
 
 ;;; Derive the result to be float for argument types in the
 ;;; appropriate domain.
-#!-propagate-fun-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (dolist (stuff '((asin (real -1.0 1.0))
 		 (acos (real -1.0 1.0))
 		 (acosh (real 1.0))
@@ -303,20 +323,20 @@
 		 (sqrt (real 0.0))))
   (destructuring-bind (name type) stuff
     (let ((type (specifier-type type)))
-      (setf (function-info-derive-type (function-info-or-lose name))
-	    #'(lambda (call)
-		(declare (type combination call))
-		(when (csubtypep (continuation-type
-				  (first (combination-args call)))
-				 type)
-		  (specifier-type 'float)))))))
-
-#!-propagate-fun-type
+      (setf (fun-info-derive-type (fun-info-or-lose name))
+	    (lambda (call)
+	      (declare (type combination call))
+	      (when (csubtypep (lvar-type
+				(first (combination-args call)))
+			       type)
+		(specifier-type 'float)))))))
+
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (log derive-type) ((x &optional y))
-  (when (and (csubtypep (continuation-type x)
+  (when (and (csubtypep (lvar-type x)
 			(specifier-type '(real 0.0)))
 	     (or (null y)
-		 (csubtypep (continuation-type y)
+		 (csubtypep (lvar-type y)
 			    (specifier-type '(real 0.0)))))
     (specifier-type 'float)))
 
@@ -327,121 +347,128 @@
   (movable foldable flushable))
 
 (defknown (%sin %cos %tanh %sin-quick %cos-quick)
-    (double-float) (double-float -1.0d0 1.0d0)
-    (movable foldable flushable))
+  (double-float) (double-float -1.0d0 1.0d0)
+  (movable foldable flushable))
 
 (defknown (%asin %atan)
-    (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
-    (movable foldable flushable))
+  (double-float)
+  (double-float #.(coerce (- (/ pi 2)) 'double-float)
+		#.(coerce (/ pi 2) 'double-float))
+  (movable foldable flushable))
 
 (defknown (%acos)
-    (double-float) (double-float 0.0d0 #.pi)
-    (movable foldable flushable))
+  (double-float) (double-float 0.0d0 #.(coerce pi 'double-float))
+  (movable foldable flushable))
 
 (defknown (%cosh)
-    (double-float) (double-float 1.0d0)
-    (movable foldable flushable))
+  (double-float) (double-float 1.0d0)
+  (movable foldable flushable))
 
 (defknown (%acosh %exp %sqrt)
-    (double-float) (double-float 0.0d0)
-    (movable foldable flushable))
+  (double-float) (double-float 0.0d0)
+  (movable foldable flushable))
 
 (defknown %expm1
-    (double-float) (double-float -1d0)
-    (movable foldable flushable))
+  (double-float) (double-float -1d0)
+  (movable foldable flushable))
 
 (defknown (%hypot)
-    (double-float double-float) (double-float 0d0)
+  (double-float double-float) (double-float 0d0)
   (movable foldable flushable))
 
 (defknown (%pow)
-    (double-float double-float) double-float
+  (double-float double-float) double-float
   (movable foldable flushable))
 
 (defknown (%atan2)
-    (double-float double-float) (double-float #.(- pi) #.pi)
+  (double-float double-float)
+  (double-float #.(coerce (- pi) 'double-float)
+		#.(coerce pi 'double-float))
   (movable foldable flushable))
 
 (defknown (%scalb)
-    (double-float double-float) double-float
+  (double-float double-float) double-float
   (movable foldable flushable))
 
 (defknown (%scalbn)
-    (double-float (signed-byte 32)) double-float
-    (movable foldable flushable))
+  (double-float (signed-byte 32)) double-float
+  (movable foldable flushable))
 
 (defknown (%log1p)
-    (double-float) double-float
-    (movable foldable flushable))
-
-(dolist (stuff '((exp %exp *)
-		 (log %log float)
-		 (sqrt %sqrt float)
-		 (asin %asin float)
-		 (acos %acos float)
-		 (atan %atan *)
-		 (sinh %sinh *)
-		 (cosh %cosh *)
-		 (tanh %tanh *)
-		 (asinh %asinh *)
-		 (acosh %acosh float)
-		 (atanh %atanh float)))
-  (destructuring-bind (name prim rtype) stuff
-    (deftransform name ((x) '(single-float) rtype :eval-name t)
-      `(coerce (,prim (coerce x 'double-float)) 'single-float))
-    (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
-      `(,prim x))))
+  (double-float) double-float
+  (movable foldable flushable))
+
+(macrolet ((def (name prim rtype)
+             `(progn
+               (deftransform ,name ((x) (single-float) ,rtype)
+                 `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+               (deftransform ,name ((x) (double-float) ,rtype)
+                 `(,',prim x)))))
+  (def exp %exp *)
+  (def log %log float)
+  (def sqrt %sqrt float)
+  (def asin %asin float)
+  (def acos %acos float)
+  (def atan %atan *)
+  (def sinh %sinh *)
+  (def cosh %cosh *)
+  (def tanh %tanh *)
+  (def asinh %asinh *)
+  (def acosh %acosh float)
+  (def atanh %atanh float))
 
 ;;; The argument range is limited on the x86 FP trig. functions. A
 ;;; post-test can detect a failure (and load a suitable result), but
 ;;; this test is avoided if possible.
-(dolist (stuff '((sin %sin %sin-quick)
-		 (cos %cos %cos-quick)
-		 (tan %tan %tan-quick)))
-  (destructuring-bind (name prim prim-quick) stuff
-    (deftransform name ((x) '(single-float) '* :eval-name t)
-      #!+x86 (cond ((csubtypep (continuation-type x)
-			       (specifier-type '(single-float
-						 (#.(- (expt 2f0 64)))
-						 (#.(expt 2f0 64)))))
-		    `(coerce (,prim-quick (coerce x 'double-float))
-		    'single-float))
-		   (t
-		    (compiler-note
-		    "unable to avoid inline argument range check~@
-		      because the argument range (~S) was not within 2^64"
-		    (type-specifier (continuation-type x)))
-		    `(coerce (,prim (coerce x 'double-float)) 'single-float)))
-      #!-x86 `(coerce (,prim (coerce x 'double-float)) 'single-float))
-    (deftransform name ((x) '(double-float) '* :eval-name t :when :both)
-      #!+x86 (cond ((csubtypep (continuation-type x)
-			       (specifier-type '(double-float
-						 (#.(- (expt 2d0 64)))
-						 (#.(expt 2d0 64)))))
-		    `(,prim-quick x))
-		   (t
-		    (compiler-note
-		    "unable to avoid inline argument range check~@
-		   because the argument range (~S) was not within 2^64"
-		    (type-specifier (continuation-type x)))
-		    `(,prim x)))
-      #!-x86 `(,prim x))))
+(macrolet ((def (name prim prim-quick)
+             (declare (ignorable prim-quick))
+             `(progn
+                (deftransform ,name ((x) (single-float) *)
+                  #!+x86 (cond ((csubtypep (lvar-type x)
+                                           (specifier-type '(single-float
+                                                             (#.(- (expt 2f0 64)))
+                                                             (#.(expt 2f0 64)))))
+                                `(coerce (,',prim-quick (coerce x 'double-float))
+                                  'single-float))
+                               (t
+                                (compiler-notify
+                                 "unable to avoid inline argument range check~@
+                                  because the argument range (~S) was not within 2^64"
+                                 (type-specifier (lvar-type x)))
+                                `(coerce (,',prim (coerce x 'double-float)) 'single-float)))
+                  #!-x86 `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+               (deftransform ,name ((x) (double-float) *)
+                 #!+x86 (cond ((csubtypep (lvar-type x)
+                                          (specifier-type '(double-float
+                                                            (#.(- (expt 2d0 64)))
+                                                            (#.(expt 2d0 64)))))
+                               `(,',prim-quick x))
+                              (t
+                               (compiler-notify
+                                "unable to avoid inline argument range check~@
+                                 because the argument range (~S) was not within 2^64"
+                                (type-specifier (lvar-type x)))
+                               `(,',prim x)))
+                 #!-x86 `(,',prim x)))))
+  (def sin %sin %sin-quick)
+  (def cos %cos %cos-quick)
+  (def tan %tan %tan-quick))
 
 (deftransform atan ((x y) (single-float single-float) *)
   `(coerce (%atan2 (coerce x 'double-float) (coerce y 'double-float))
     'single-float))
-(deftransform atan ((x y) (double-float double-float) * :when :both)
+(deftransform atan ((x y) (double-float double-float) *)
   `(%atan2 x y))
 
 (deftransform expt ((x y) ((single-float 0f0) single-float) *)
   `(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
     'single-float))
-(deftransform expt ((x y) ((double-float 0d0) double-float) * :when :both)
+(deftransform expt ((x y) ((double-float 0d0) double-float) *)
   `(%pow x y))
 (deftransform expt ((x y) ((single-float 0f0) (signed-byte 32)) *)
   `(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
     'single-float))
-(deftransform expt ((x y) ((double-float 0d0) (signed-byte 32)) * :when :both)
+(deftransform expt ((x y) ((double-float 0d0) (signed-byte 32)) *)
   `(%pow x (coerce y 'double-float)))
 
 ;;; ANSI says log with base zero returns zero.
@@ -450,7 +477,7 @@
 
 ;;; Handle some simple transformations.
 
-(deftransform abs ((x) ((complex double-float)) double-float :when :both)
+(deftransform abs ((x) ((complex double-float)) double-float)
   '(%hypot (realpart x) (imagpart x)))
 
 (deftransform abs ((x) ((complex single-float)) single-float)
@@ -458,7 +485,7 @@
 		   (coerce (imagpart x) 'double-float))
 	  'single-float))
 
-(deftransform phase ((x) ((complex double-float)) double-float :when :both)
+(deftransform phase ((x) ((complex double-float)) double-float)
   '(%atan2 (imagpart x) (realpart x)))
 
 (deftransform phase ((x) ((complex single-float)) single-float)
@@ -466,16 +493,12 @@
 		   (coerce (realpart x) 'double-float))
 	  'single-float))
 
-(deftransform phase ((x) ((float)) float :when :both)
+(deftransform phase ((x) ((float)) float)
   '(if (minusp (float-sign x))
        (float pi x)
        (float 0 x)))
 
-#!+(or propagate-float-type propagate-fun-type)
-(progn
-
 ;;; The number is of type REAL.
-#!-sb-fluid (declaim (inline numeric-type-real-p))
 (defun numeric-type-real-p (type)
   (and (numeric-type-p type)
        (eq (numeric-type-complexp type) :real)))
@@ -488,9 +511,7 @@
 	(list (coerce (car bound) type))
 	(coerce bound type))))
 
-) ; PROGN
-
-#!+propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 
 ;;;; optimizers for elementary functions
@@ -508,7 +529,7 @@
 	 (float-type (or format 'float)))
     (specifier-type `(complex ,float-type))))
 
-;;; Compute a specifier like '(or float (complex float)), except float
+;;; Compute a specifier like '(OR FLOAT (COMPLEX FLOAT)), except float
 ;;; should be the right kind of float. Allow bounds for the float
 ;;; part too.
 (defun float-or-complex-float-type (arg &optional lo hi)
@@ -522,43 +543,55 @@
     (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
 			 (complex ,float-type)))))
 
+) ; PROGN
+
+(eval-when (:compile-toplevel :execute)
+  ;; So the problem with this hack is that it's actually broken.  If
+  ;; the host does not have long floats, then setting *R-D-F-F* to
+  ;; LONG-FLOAT doesn't actually buy us anything.  FIXME.
+  (setf *read-default-float-format*
+	#!+long-float 'long-float #!-long-float 'double-float))
 ;;; Test whether the numeric-type ARG is within in domain specified by
 ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
-;;; be distinct as for the :negative-zero-is-not-zero feature. With
-;;; the :negative-zero-is-not-zero feature this could be handled by
-;;; the numeric subtype code in type.lisp.
+;;; be distinct.
+#-sb-xc-host  ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defun domain-subtypep (arg domain-low domain-high)
   (declare (type numeric-type arg)
 	   (type (or real null) domain-low domain-high))
   (let* ((arg-lo (numeric-type-low arg))
-	 (arg-lo-val (bound-value arg-lo))
+	 (arg-lo-val (type-bound-number arg-lo))
 	 (arg-hi (numeric-type-high arg))
-	 (arg-hi-val (bound-value arg-hi)))
+	 (arg-hi-val (type-bound-number arg-hi)))
     ;; Check that the ARG bounds are correctly canonicalized.
     (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
 	       (minusp (float-sign arg-lo-val)))
-      (compiler-note "float zero bound ~S not correctly canonicalized?" arg-lo)
-      (setq arg-lo '(0l0) arg-lo-val 0l0))
+      (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo)
+      (setq arg-lo 0e0 arg-lo-val arg-lo))
     (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
 	       (plusp (float-sign arg-hi-val)))
-      (compiler-note "float zero bound ~S not correctly canonicalized?" arg-hi)
-      (setq arg-hi '(-0l0) arg-hi-val -0l0))
-    (and (or (null domain-low)
-	     (and arg-lo (>= arg-lo-val domain-low)
-		  (not (and (zerop domain-low) (floatp domain-low)
-			    (plusp (float-sign domain-low))
-			    (zerop arg-lo-val) (floatp arg-lo-val)
-			    (if (consp arg-lo)
-				(plusp (float-sign arg-lo-val))
-				(minusp (float-sign arg-lo-val)))))))
-	 (or (null domain-high)
-	     (and arg-hi (<= arg-hi-val domain-high)
-		  (not (and (zerop domain-high) (floatp domain-high)
-			    (minusp (float-sign domain-high))
-			    (zerop arg-hi-val) (floatp arg-hi-val)
-			    (if (consp arg-hi)
-				(minusp (float-sign arg-hi-val))
-				(plusp (float-sign arg-hi-val))))))))))
+      (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi)
+      (setq arg-hi (ecase *read-default-float-format*
+                     (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+                     #!+long-float
+                     (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))
+	    arg-hi-val arg-hi))
+    (flet ((fp-neg-zero-p (f)           ; Is F -0.0?
+	     (and (floatp f) (zerop f) (minusp (float-sign f))))
+	   (fp-pos-zero-p (f)           ; Is F +0.0?
+	     (and (floatp f) (zerop f) (plusp (float-sign f)))))
+      (and (or (null domain-low)
+               (and arg-lo (>= arg-lo-val domain-low)
+                    (not (and (fp-pos-zero-p domain-low)
+			      (fp-neg-zero-p arg-lo)))))
+           (or (null domain-high)
+               (and arg-hi (<= arg-hi-val domain-high)
+                    (not (and (fp-neg-zero-p domain-high)
+			      (fp-pos-zero-p arg-hi)))))))))
+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format* 'single-float))
+
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+(progn
 
 ;;; Handle monotonic functions of a single variable whose domain is
 ;;; possibly part of the real line. ARG is the variable, FCN is the
@@ -569,8 +602,7 @@
 ;;; result, which occurs for the parts of ARG not in the DOMAIN.
 ;;;
 ;;; Negative and positive zero are considered distinct within
-;;; DOMAIN-LOW and DOMAIN-HIGH, as for the :negative-zero-is-not-zero
-;;; feature.
+;;; DOMAIN-LOW and DOMAIN-HIGH.
 ;;;
 ;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we
 ;;; can't compute the bounds using FCN.
@@ -604,7 +636,6 @@
 				    default-low))
 			(res-hi (or (bound-func fcn (if increasingp high low))
 				    default-high))
-			;; Result specifier type.
 			(format (case (numeric-type-class arg)
 				  ((integer rational) 'single-float)
 				  (t (numeric-type-format arg))))
@@ -637,11 +668,11 @@
 	 `(defoptimizer (,name derive-type) ((,num))
 	   (one-arg-derive-type
 	    ,num
-	    #'(lambda (arg)
-		(elfun-derive-type-simple arg #',name
-					  ,domain-low ,domain-high
-					  ,def-low-bnd ,def-high-bnd
-					  ,increasingp))
+	    (lambda (arg)
+	      (elfun-derive-type-simple arg #',name
+					,domain-low ,domain-high
+					,def-low-bnd ,def-high-bnd
+					,increasingp))
 	    #',name)))))
   ;; These functions are easy because they are defined for the whole
   ;; real line.
@@ -660,37 +691,38 @@
   (frob atanh -1d0 1d0 -1 1)
   ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
   ;; includes -0.0.
-  (frob sqrt -0d0 nil 0 nil))
+  (frob sqrt (load-time-value (make-unportable-float :double-float-negative-zero)) nil 0 nil))
 
 ;;; Compute bounds for (expt x y). This should be easy since (expt x
 ;;; y) = (exp (* y (log x))). However, computations done this way
 ;;; have too much roundoff. Thus we have to do it the hard way.
 (defun safe-expt (x y)
   (handler-case
-      (expt x y)
+      (when (< (abs y) 10000)
+        (expt x y))
     (error ()
       nil)))
 
 ;;; Handle the case when x >= 1.
 (defun interval-expt-> (x y)
   (case (sb!c::interval-range-info y 0d0)
-    ('+
+    (+
      ;; Y is positive and log X >= 0. The range of exp(y * log(x)) is
      ;; obviously non-negative. We just have to be careful for
      ;; infinite bounds (given by nil).
-     (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
-			  (sb!c::bound-value (sb!c::interval-low y))))
-	   (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
-			  (sb!c::bound-value (sb!c::interval-high y)))))
+     (let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
+			  (type-bound-number (sb!c::interval-low y))))
+	   (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+			  (type-bound-number (sb!c::interval-high y)))))
        (list (sb!c::make-interval :low (or lo 1) :high hi))))
-    ('-
+    (-
      ;; Y is negative and log x >= 0. The range of exp(y * log(x)) is
      ;; obviously [0, 1]. However, underflow (nil) means 0 is the
      ;; result.
-     (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
-			  (sb!c::bound-value (sb!c::interval-low y))))
-	   (hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
-			  (sb!c::bound-value (sb!c::interval-high y)))))
+     (let ((lo (safe-expt (type-bound-number (sb!c::interval-high x))
+			  (type-bound-number (sb!c::interval-low y))))
+	   (hi (safe-expt (type-bound-number (sb!c::interval-low x))
+			  (type-bound-number (sb!c::interval-high y)))))
        (list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
     (t
      ;; Split the interval in half.
@@ -702,25 +734,25 @@
 ;;; Handle the case when x <= 1
 (defun interval-expt-< (x y)
   (case (sb!c::interval-range-info x 0d0)
-    ('+
+    (+
      ;; The case of 0 <= x <= 1 is easy
      (case (sb!c::interval-range-info y)
-       ('+
+       (+
 	;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
 	;; obviously [0, 1]. We just have to be careful for infinite bounds
 	;; (given by nil).
-	(let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
-			     (sb!c::bound-value (sb!c::interval-high y))))
-	      (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
-			     (sb!c::bound-value (sb!c::interval-low y)))))
+	(let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
+			     (type-bound-number (sb!c::interval-high y))))
+	      (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+			     (type-bound-number (sb!c::interval-low y)))))
 	  (list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
-       ('-
+       (-
 	;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
 	;; obviously [1, inf].
-	(let ((hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
-			     (sb!c::bound-value (sb!c::interval-low y))))
-	      (lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
-			     (sb!c::bound-value (sb!c::interval-high y)))))
+	(let ((hi (safe-expt (type-bound-number (sb!c::interval-low x))
+			     (type-bound-number (sb!c::interval-low y))))
+	      (lo (safe-expt (type-bound-number (sb!c::interval-high x))
+			     (type-bound-number (sb!c::interval-high y)))))
 	  (list (sb!c::make-interval :low (or lo 1) :high hi))))
        (t
 	;; Split the interval in half
@@ -728,7 +760,7 @@
 	    (sb!c::interval-split 0 y t)
 	  (list (interval-expt-< x y-)
 		(interval-expt-< x y+))))))
-    ('-
+    (-
      ;; The case where x <= 0. Y MUST be an INTEGER for this to work!
      ;; The calling function must insure this! For now we'll just
      ;; return the appropriate unbounded float type.
@@ -740,13 +772,12 @@
 	     (interval-expt-< pos y))))))
 
 ;;; Compute bounds for (expt x y).
-
 (defun interval-expt (x y)
   (case (interval-range-info x 1)
-    ('+
+    (+
      ;; X >= 1
 	 (interval-expt-> x y))
-    ('-
+    (-
      ;; X <= 1
      (interval-expt-< x y))
     (t
@@ -760,7 +791,7 @@
   ;; Figure out what the return type should be, given the argument
   ;; types and bounds and the result type and bounds.
   (cond ((csubtypep x-type (specifier-type 'integer))
-	 ;; An integer to some power. Cases to consider:
+	 ;; an integer to some power
 	 (case (numeric-type-class y-type)
 	   (integer
 	    ;; Positive integer to an integer power is either an
@@ -768,7 +799,7 @@
 	    (let ((lo (or (interval-low bnd) '*))
 		  (hi (or (interval-high bnd) '*)))
 	      (if (and (interval-low y-int)
-		       (>= (bound-value (interval-low y-int)) 0))
+		       (>= (type-bound-number (interval-low y-int)) 0))
 		  (specifier-type `(integer ,lo ,hi))
 		  (specifier-type `(rational ,lo ,hi)))))
 	   (rational
@@ -777,10 +808,10 @@
 	    (let* ((lo (interval-low bnd))
 		   (hi (interval-high bnd))
 		   (int-lo (if lo
-			       (floor (bound-value lo))
+			       (floor (type-bound-number lo))
 			       '*))
 		   (int-hi (if hi
-			       (ceiling (bound-value hi))
+			       (ceiling (type-bound-number hi))
 			       '*))
 		   (f-lo (if lo
 			     (bound-func #'float lo)
@@ -791,32 +822,30 @@
 	      (specifier-type `(or (rational ,int-lo ,int-hi)
 				(single-float ,f-lo, f-hi)))))
 	   (float
-	    ;; Positive integer to a float power is a float.
-	    (let ((res (copy-numeric-type y-type)))
-	      (setf (numeric-type-low res) (interval-low bnd))
-	      (setf (numeric-type-high res) (interval-high bnd))
-	      res))
+	    ;; A positive integer to a float power is a float.
+	    (modified-numeric-type y-type
+				   :low (interval-low bnd)
+				   :high (interval-high bnd)))
 	   (t
-	    ;; Positive integer to a number is a number (for now).
-	    (specifier-type 'number)))
-	 )
+	    ;; A positive integer to a number is a number (for now).
+	    (specifier-type 'number))))
 	((csubtypep x-type (specifier-type 'rational))
 	 ;; a rational to some power
 	 (case (numeric-type-class y-type)
 	   (integer
-	    ;; Positive rational to an integer power is always a rational.
+	    ;; A positive rational to an integer power is always a rational.
 	    (specifier-type `(rational ,(or (interval-low bnd) '*)
 				       ,(or (interval-high bnd) '*))))
 	   (rational
-	    ;; Positive rational to rational power is either a rational
+	    ;; A positive rational to rational power is either a rational
 	    ;; or a single-float.
 	    (let* ((lo (interval-low bnd))
 		   (hi (interval-high bnd))
 		   (int-lo (if lo
-			       (floor (bound-value lo))
+			       (floor (type-bound-number lo))
 			       '*))
 		   (int-hi (if hi
-			       (ceiling (bound-value hi))
+			       (ceiling (type-bound-number hi))
 			       '*))
 		   (f-lo (if lo
 			     (bound-func #'float lo)
@@ -827,20 +856,18 @@
 	      (specifier-type `(or (rational ,int-lo ,int-hi)
 				(single-float ,f-lo, f-hi)))))
 	   (float
-	    ;; Positive rational to a float power is a float.
-	    (let ((res (copy-numeric-type y-type)))
-	      (setf (numeric-type-low res) (interval-low bnd))
-	      (setf (numeric-type-high res) (interval-high bnd))
-	      res))
+	    ;; A positive rational to a float power is a float.
+	    (modified-numeric-type y-type
+				   :low (interval-low bnd)
+				   :high (interval-high bnd)))
 	   (t
-	    ;; Positive rational to a number is a number (for now).
-	    (specifier-type 'number)))
-	 )
+	    ;; A positive rational to a number is a number (for now).
+	    (specifier-type 'number))))
 	((csubtypep x-type (specifier-type 'float))
 	 ;; a float to some power
 	 (case (numeric-type-class y-type)
 	   ((or integer rational)
-	    ;; Positive float to an integer or rational power is
+	    ;; A positive float to an integer or rational power is
 	    ;; always a float.
 	    (make-numeric-type
 	     :class 'float
@@ -848,7 +875,8 @@
 	     :low (interval-low bnd)
 	     :high (interval-high bnd)))
 	   (float
-	    ;; Positive float to a float power is a float of the higher type.
+	    ;; A positive float to a float power is a float of the
+	    ;; higher type.
 	    (make-numeric-type
 	     :class 'float
 	     :format (float-format-max (numeric-type-format x-type)
@@ -856,7 +884,7 @@
 	     :low (interval-low bnd)
 	     :high (interval-high bnd)))
 	   (t
-	    ;; Positive float to a number is a number (for now)
+	    ;; A positive float to a number is a number (for now)
 	    (specifier-type 'number))))
 	(t
 	 ;; A number to some power is a number.
@@ -865,8 +893,8 @@
 (defun merged-interval-expt (x y)
   (let* ((x-int (numeric-type->interval x))
 	 (y-int (numeric-type->interval y)))
-    (mapcar #'(lambda (type)
-		(fixup-interval-expt type x-int y-int x y))
+    (mapcar (lambda (type)
+	      (fixup-interval-expt type x-int y-int x y))
 	    (flatten-list (interval-expt x-int y-int)))))
 
 (defun expt-derive-type-aux (x y same-arg)
@@ -878,17 +906,21 @@
 	((csubtypep y (specifier-type 'integer))
 	 ;; A real raised to an integer power is well-defined.
 	 (merged-interval-expt x y))
+	;; A real raised to a non-integral power can be a float or a
+	;; complex number.
+	((or (csubtypep x (specifier-type '(rational 0)))
+	     (csubtypep x (specifier-type '(float (0d0)))))
+	 ;; But a positive real to any power is well-defined.
+	 (merged-interval-expt x y))
+	((and (csubtypep x (specifier-type 'rational))
+	      (csubtypep x (specifier-type 'rational)))
+	 ;; A rational to the power of a rational could be a rational
+	 ;; or a possibly-complex single float
+	 (specifier-type '(or rational single-float (complex single-float))))
 	(t
-	 ;; A real raised to a non-integral power can be a float or a
-	 ;; complex number.
-	 (cond ((or (csubtypep x (specifier-type '(rational 0)))
-		    (csubtypep x (specifier-type '(float (0d0)))))
-		;; But a positive real to any power is well-defined.
-		(merged-interval-expt x y))
-	       (t
-		;; A real to some power. The result could be a real
-		;; or a complex.
-		(float-or-complex-float-type (numeric-contagion x y)))))))
+	 ;; a real to some power. The result could be a real or a
+	 ;; complex.
+	 (float-or-complex-float-type (numeric-contagion x y)))))
 
 (defoptimizer (expt derive-type) ((x y))
   (two-arg-derive-type x y #'expt-derive-type-aux #'expt))
@@ -901,16 +933,13 @@
 (defun log-derive-type-aux-2 (x y same-arg)
   (let ((log-x (log-derive-type-aux-1 x))
 	(log-y (log-derive-type-aux-1 y))
-	(result '()))
-    ;; log-x or log-y might be union types. We need to run through
-    ;; the union types ourselves because /-derive-type-aux doesn't.
+	(accumulated-list nil))
+    ;; LOG-X or LOG-Y might be union types. We need to run through
+    ;; the union types ourselves because /-DERIVE-TYPE-AUX doesn't.
     (dolist (x-type (prepare-arg-for-derive-type log-x))
       (dolist (y-type (prepare-arg-for-derive-type log-y))
-	(push (/-derive-type-aux x-type y-type same-arg) result)))
-    (setf result (flatten-list result))
-    (if (rest result)
-	(make-union-type-or-something result)
-	(first result))))
+	(push (/-derive-type-aux x-type y-type same-arg) accumulated-list)))
+    (apply #'type-union (flatten-list accumulated-list))))
 
 (defoptimizer (log derive-type) ((x &optional y))
   (if y
@@ -926,7 +955,9 @@
   (let ((result-type (numeric-contagion y x)))
     (cond ((and (numeric-type-real-p x)
 		(numeric-type-real-p y))
-	   (let* ((format (case (numeric-type-class result-type)
+	   (let* (;; FIXME: This expression for FORMAT seems to
+		  ;; appear multiple times, and should be factored out.
+		  (format (case (numeric-type-class result-type)
 			    ((integer rational) 'single-float)
 			    (t (numeric-type-format result-type))))
 		  (bound-format (or format 'float)))
@@ -962,14 +993,14 @@
 	 (bound-type (or format 'float)))
     (cond ((numeric-type-real-p arg)
 	   (case (interval-range-info (numeric-type->interval arg) 0.0)
-	     ('+
+	     (+
 	      ;; The number is positive, so the phase is 0.
 	      (make-numeric-type :class 'float
 				 :format format
 				 :complexp :real
 				 :low (coerce 0 bound-type)
 				 :high (coerce 0 bound-type)))
-	     ('-
+	     (-
 	      ;; The number is always negative, so the phase is pi.
 	      (make-numeric-type :class 'float
 				 :format format
@@ -1031,7 +1062,7 @@
 			      :complexp :real
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type))))))
-#!+(or propagate-fun-type propagate-float-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (realpart derive-type) ((num))
   (one-arg-derive-type num #'realpart-derive-type-aux #'realpart))
 (defun imagpart-derive-type-aux (type)
@@ -1055,7 +1086,7 @@
 			      :complexp :real
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type))))))
-#!+(or propagate-fun-type propagate-float-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (imagpart derive-type) ((num))
   (one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart))
 
@@ -1087,10 +1118,9 @@
 	     (rat-result-p (csubtypep element-type
 				      (specifier-type 'rational))))
 	(if rat-result-p
-	    (make-union-type-or-something
-	     (list element-type
-		   (specifier-type
-		    `(complex ,(numeric-type-class element-type)))))
+	    (type-union element-type
+			(specifier-type
+			 `(complex ,(numeric-type-class element-type))))
 	    (make-numeric-type :class (numeric-type-class element-type)
 			       :format (numeric-type-format element-type)
 			       :complexp (if rat-result-p
@@ -1098,7 +1128,7 @@
 					     :complex))))
       (specifier-type 'complex)))
 
-#!+(or propagate-fun-type propagate-float-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (complex derive-type) ((re &optional im))
   (if im
       (two-arg-derive-type re im #'complex-derive-type-aux-2 #'complex)
@@ -1176,13 +1206,12 @@
   (frob single-float)
   (frob double-float))
 
-;;; Here are simple optimizers for sin, cos, and tan. They do not
+;;; Here are simple optimizers for SIN, COS, and TAN. They do not
 ;;; produce a minimal range for the result; the result is the widest
 ;;; possible answer. This gets around the problem of doing range
 ;;; reduction correctly but still provides useful results when the
 ;;; inputs are union types.
-
-#!+propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 (defun trig-derive-type-aux (arg domain fcn
 				 &optional def-lo def-hi (increasingp t))
@@ -1225,47 +1254,148 @@
 (defoptimizer (sin derive-type) ((num))
   (one-arg-derive-type
    num
-   #'(lambda (arg)
-       ;; Derive the bounds if the arg is in [-pi/2, pi/2].
-       (trig-derive-type-aux
-	arg
-	(specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
-	#'sin
-	-1 1))
+   (lambda (arg)
+     ;; Derive the bounds if the arg is in [-pi/2, pi/2].
+     (trig-derive-type-aux
+      arg
+      (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
+      #'sin
+      -1 1))
    #'sin))
 
 (defoptimizer (cos derive-type) ((num))
   (one-arg-derive-type
    num
-   #'(lambda (arg)
-       ;; Derive the bounds if the arg is in [0, pi].
-       (trig-derive-type-aux arg
-			     (specifier-type `(float 0d0 ,pi))
-			     #'cos
-			     -1 1
-			     nil))
+   (lambda (arg)
+     ;; Derive the bounds if the arg is in [0, pi].
+     (trig-derive-type-aux arg
+			   (specifier-type `(float 0d0 ,pi))
+			   #'cos
+			   -1 1
+			   nil))
    #'cos))
 
 (defoptimizer (tan derive-type) ((num))
   (one-arg-derive-type
    num
-   #'(lambda (arg)
-       ;; Derive the bounds if the arg is in [-pi/2, pi/2].
-       (trig-derive-type-aux arg
-			     (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
-			     #'tan
-			     nil nil))
+   (lambda (arg)
+     ;; Derive the bounds if the arg is in [-pi/2, pi/2].
+     (trig-derive-type-aux arg
+			   (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
+			   #'tan
+			   nil nil))
    #'tan))
 
 ;;; CONJUGATE always returns the same type as the input type.
+;;;
+;;; FIXME: ANSI allows any subtype of REAL for the components of COMPLEX.
+;;; So what if the input type is (COMPLEX (SINGLE-FLOAT 0 1))?
 (defoptimizer (conjugate derive-type) ((num))
-  (continuation-type num))
+  (lvar-type num))
 
 (defoptimizer (cis derive-type) ((num))
   (one-arg-derive-type num
-     #'(lambda (arg)
-	 (sb!c::specifier-type
-	  `(complex ,(or (numeric-type-format arg) 'float))))
+     (lambda (arg)
+       (sb!c::specifier-type
+	`(complex ,(or (numeric-type-format arg) 'float))))
      #'cis))
 
 ) ; PROGN
+
+;;;; TRUNCATE, FLOOR, CEILING, and ROUND
+
+(macrolet ((define-frobs (fun ufun)
+	     `(progn
+		(defknown ,ufun (real) integer (movable foldable flushable))
+		(deftransform ,fun ((x &optional by)
+				    (* &optional
+				       (constant-arg (member 1))))
+		  '(let ((res (,ufun x)))
+		     (values res (- x res)))))))
+  (define-frobs truncate %unary-truncate)
+  (define-frobs round %unary-round))
+
+;;; Convert (TRUNCATE x y) to the obvious implementation.  We only want
+;;; this when under certain conditions and let the generic TRUNCATE
+;;; handle the rest.  (Note: if Y = 1, the divide and multiply by Y
+;;; should be removed by other DEFTRANSFORMs.)
+(deftransform truncate ((x &optional y)
+                        (float &optional (or float integer)))
+  (let ((defaulted-y (if y 'y 1)))
+    `(let ((res (%unary-truncate (/ x ,defaulted-y))))
+       (values res (- x (* ,defaulted-y res))))))
+
+(deftransform floor ((number &optional divisor)
+                     (float &optional (or integer float)))
+  (let ((defaulted-divisor (if divisor 'divisor 1)))
+    `(multiple-value-bind (tru rem) (truncate number ,defaulted-divisor)
+       (if (and (not (zerop rem))
+		(if (minusp ,defaulted-divisor)
+		    (plusp number)
+		    (minusp number)))
+	   (values (1- tru) (+ rem ,defaulted-divisor))
+	   (values tru rem)))))
+
+(deftransform ceiling ((number &optional divisor)
+                       (float &optional (or integer float)))
+  (let ((defaulted-divisor (if divisor 'divisor 1)))
+    `(multiple-value-bind (tru rem) (truncate number ,defaulted-divisor)
+       (if (and (not (zerop rem))
+		(if (minusp ,defaulted-divisor)
+		    (minusp number)
+		    (plusp number)))
+	   (values (1+ tru) (- rem ,defaulted-divisor))
+	   (values tru rem)))))
+
+(defknown %unary-ftruncate (real) float (movable foldable flushable))
+(defknown %unary-ftruncate/single (single-float) single-float
+  (movable foldable flushable))
+(defknown %unary-ftruncate/double (double-float) double-float
+  (movable foldable flushable))
+
+(defun %unary-ftruncate/single (x)
+  (declare (type single-float x))
+  (declare (optimize speed (safety 0)))
+  (let* ((bits (single-float-bits x))
+	 (exp (ldb sb!vm:single-float-exponent-byte bits))
+	 (biased (the single-float-exponent
+		   (- exp sb!vm:single-float-bias))))
+    (declare (type (signed-byte 32) bits))
+    (cond
+      ((= exp sb!vm:single-float-normal-exponent-max) x)
+      ((<= biased 0) (* x 0f0))
+      ((>= biased (float-digits x)) x)
+      (t
+       (let ((frac-bits (- (float-digits x) biased)))
+	 (setf bits (logandc2 bits (- (ash 1 frac-bits) 1)))
+	 (make-single-float bits))))))
+
+(defun %unary-ftruncate/double (x)
+  (declare (type double-float x))
+  (declare (optimize speed (safety 0)))
+  (let* ((high (double-float-high-bits x))
+	 (low (double-float-low-bits x))
+	 (exp (ldb sb!vm:double-float-exponent-byte high))
+	 (biased (the double-float-exponent
+		   (- exp sb!vm:double-float-bias))))
+    (declare (type (signed-byte 32) high)
+	     (type (unsigned-byte 32) low))
+    (cond
+      ((= exp sb!vm:double-float-normal-exponent-max) x)
+      ((<= biased 0) (* x 0d0))
+      ((>= biased (float-digits x)) x)
+      (t
+       (let ((frac-bits (- (float-digits x) biased)))
+	 (cond ((< frac-bits 32)
+		(setf low (logandc2 low (- (ash 1 frac-bits) 1))))
+	       (t
+		(setf low 0)
+		(setf high (logandc2 high (- (ash 1 (- frac-bits 32)) 1)))))
+	 (make-double-float high low))))))
+
+(macrolet
+    ((def (float-type fun)
+	 `(deftransform %unary-ftruncate ((x) (,float-type))
+	    '(,fun x))))
+  (def single-float %unary-ftruncate/single)
+  (def double-float %unary-ftruncate/double))