X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat.lisp;h=29cefa36f85c41c84c46cb8048723e8b1b296c17;hb=62d333e05a6ae7de4e7b5c918d67608a457b3da7;hp=c0e0419c5e788851ab6e8eb222f4878ea5cbeaa3;hpb=43980afbf2f02ff68b3cfb62be9051fabe164de0;p=sbcl.git

diff --git a/src/code/float.lisp b/src/code/float.lisp
index c0e0419..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.