X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat.lisp;h=29cefa36f85c41c84c46cb8048723e8b1b296c17;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=2d8d467a5fedd61d7c3f8a05a87728fa636424f1;hpb=347cb8c2f9f2a3f9b92cad1b326b2ae0b629dea5;p=sbcl.git

diff --git a/src/code/float.lisp b/src/code/float.lisp
index 2d8d467..29cefa3 100644
--- a/src/code/float.lisp
+++ b/src/code/float.lisp
@@ -522,43 +522,51 @@
 ;;; Scale a single or double float, calling the correct over/underflow
 ;;; functions.
 (defun scale-single-float (x exp)
-  (declare (single-float x) (fixnum exp))
-  (let* ((bits (single-float-bits x))
-	 (old-exp (ldb sb!vm:single-float-exponent-byte bits))
-	 (new-exp (+ old-exp exp)))
-    (cond
-     ((zerop x) x)
-     ((or (< old-exp sb!vm:single-float-normal-exponent-min)
-	  (< new-exp sb!vm:single-float-normal-exponent-min))
-      (scale-float-maybe-underflow x exp))
-     ((or (> old-exp sb!vm:single-float-normal-exponent-max)
-	  (> new-exp sb!vm:single-float-normal-exponent-max))
-      (scale-float-maybe-overflow x exp))
-     (t
-      (make-single-float (dpb new-exp
-			      sb!vm:single-float-exponent-byte
-			      bits))))))
+  (declare (single-float x) (integer exp))
+  (etypecase exp
+    (fixnum
+     (let* ((bits (single-float-bits x))
+	    (old-exp (ldb sb!vm:single-float-exponent-byte bits))
+	    (new-exp (+ old-exp exp)))
+       (cond
+	 ((zerop x) x)
+	 ((or (< old-exp sb!vm:single-float-normal-exponent-min)
+	      (< new-exp sb!vm:single-float-normal-exponent-min))
+	  (scale-float-maybe-underflow x exp))
+	 ((or (> old-exp sb!vm:single-float-normal-exponent-max)
+	      (> new-exp sb!vm:single-float-normal-exponent-max))
+	  (scale-float-maybe-overflow x exp))
+	 (t
+	  (make-single-float (dpb new-exp
+				  sb!vm:single-float-exponent-byte
+				  bits))))))
+    (unsigned-byte (scale-float-maybe-overflow x exp))
+    ((integer * 0) (scale-float-maybe-underflow x exp))))
 (defun scale-double-float (x exp)
-  (declare (double-float x) (fixnum exp))
-  (let* ((hi (double-float-high-bits x))
-	 (lo (double-float-low-bits x))
-	 (old-exp (ldb sb!vm:double-float-exponent-byte hi))
-	 (new-exp (+ old-exp exp)))
-    (cond
-     ((zerop x) x)
-     ((or (< old-exp sb!vm:double-float-normal-exponent-min)
-	  (< new-exp sb!vm:double-float-normal-exponent-min))
-      (scale-float-maybe-underflow x exp))
-     ((or (> old-exp sb!vm:double-float-normal-exponent-max)
-	  (> new-exp sb!vm:double-float-normal-exponent-max))
-      (scale-float-maybe-overflow x exp))
-     (t
-      (make-double-float (dpb new-exp sb!vm:double-float-exponent-byte hi)
-			 lo)))))
+  (declare (double-float x) (integer exp))
+  (etypecase exp
+    (fixnum
+     (let* ((hi (double-float-high-bits x))
+	    (lo (double-float-low-bits x))
+	    (old-exp (ldb sb!vm:double-float-exponent-byte hi))
+	    (new-exp (+ old-exp exp)))
+       (cond
+	 ((zerop x) x)
+	 ((or (< old-exp sb!vm:double-float-normal-exponent-min)
+	      (< new-exp sb!vm:double-float-normal-exponent-min))
+	  (scale-float-maybe-underflow x exp))
+	 ((or (> old-exp sb!vm:double-float-normal-exponent-max)
+	      (> new-exp sb!vm:double-float-normal-exponent-max))
+	  (scale-float-maybe-overflow x exp))
+	 (t
+	  (make-double-float (dpb new-exp sb!vm:double-float-exponent-byte hi)
+			     lo)))))
+    (unsigned-byte (scale-float-maybe-overflow x exp))
+    ((integer * 0) (scale-float-maybe-underflow x exp))))
 
 #!+(and x86 long-float)
 (defun scale-long-float (x exp)
-  (declare (long-float x) (fixnum exp))
+  (declare (long-float x) (integer exp))
   (scale-float x exp))
 
 ;;; Dispatch to the correct type-specific scale-float function.
@@ -779,6 +787,13 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer.
 		 (- rounded)
 		 rounded)))))))
 
+(defun %unary-ftruncate (number)
+  (number-dispatch ((number real))
+    ((integer) (float number))
+    ((ratio) (float (truncate (numerator number) (denominator number))))
+    (((foreach single-float double-float #!+long-float long-float))
+     (%unary-ftruncate number))))
+
 (defun rational (x)
   #!+sb-doc
   "RATIONAL produces a rational number for any real numeric argument. This is