0.8.12.31:

	Fix bug 269 (also rediscovered by Peter Seibel on
	comp.lang.lisp)
	... SCALE-FLOAT scales floats by integers, not just
		float-exponents;
	... write code to minimize generic calls, not that I think
		SCALE-FLOAT is likely to be on many critical paths;
	... tests

diff --git a/BUGS b/BUGS
index 10fb8d1..c382343 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -908,9 +908,6 @@ WORKAROUND:
                (list x y)))
         (funcall (eval #'foo) 1)))
 
-269:
-  SCALE-FLOAT should accept any integer for its second argument.
-
 270:
   In the following function constraint propagator optimizes nothing:
 

diff --git a/NEWS b/NEWS
index dbad6fe..e8efa95 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -24,6 +24,8 @@ changes in sbcl-0.8.13 relative to sbcl-0.8.12:
   * fixed bug #334: programmatic addition of slots using specialized
     methods on SB-MOP:COMPUTE-SLOTS works for :ALLOCATION :INSTANCE
     and :ALLOCATION :CLASS slots.
+  * fixed bug #269: SCALE-FLOAT scales floats by any integer, not just
+    float exponents.  (rereported by Peter Seibel)
   * fixed a bug: #\Space (and other whitespace characters) are no
     longer considered to be macro characters in standard syntax by
     GET-MACRO-CHARACTER.

diff --git a/src/code/float.lisp b/src/code/float.lisp
index c0e0419..29cefa3 100644 (file)
--- 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.

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 8676c1e..ec1fabf 100644 (file)
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -137,10 +137,10 @@
   (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) *)

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 77430a4..af64d73 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -340,7 +340,7 @@
 
 (defknown decode-float (float) (values float float-exponent float)
   (movable foldable flushable explicit-check))
-(defknown scale-float (float float-exponent) float
+(defknown scale-float (float integer) float
   (movable foldable unsafely-flushable explicit-check))
 (defknown float-radix (float) float-radix
   (movable foldable flushable))

diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp
index dfa417e..ad9b77b 100644 (file)
--- a/tests/float.pure.lisp
+++ b/tests/float.pure.lisp
@@ -58,13 +58,6 @@
 (when (subtypep 'single-float 'short-float)
   (assert (eql least-positive-single-float least-positive-short-float)))
 
-#+nil ; bug 269
-(let ((f (eval 'least-positive-double-float)))
-  (assert (eql (multiple-value-bind (signif expon sign)
-                   (integer-decode-float f)
-                 (scale-float (float signif f) expon))
-               f)))
-
 ;;; bug found by Paul Dietz: FFLOOR and similar did not work for integers
 (let ((tests '(((ffloor -8 3) (-3.0 1))
                ((fround -8 3) (-3.0 1))
@@ -85,3 +78,20 @@
 
 ;;; bug found by Paul Dietz: bad rounding on small floats
 (assert (= (fround least-positive-short-float least-positive-short-float) 1.0))
+
+;;; bug found by Peter Seibel: scale-float was only accepting float
+;;; exponents, when it should accept all integers.  (also bug #269)
+(assert (= (multiple-value-bind (significand expt sign)
+              (integer-decode-float least-positive-double-float)
+            (* (scale-float (float significand 0.0d0) expt) sign))
+          least-positive-double-float))
+(assert (= (multiple-value-bind (significand expt sign)
+              (decode-float least-positive-double-float)
+            (* (scale-float significand expt) sign))
+          least-positive-double-float))
+(assert (= 0.0 (scale-float 1.0 most-negative-fixnum)))
+(assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum))))
+(assert (raises-error? (scale-float 1.0 most-positive-fixnum)
+                      floating-point-overflow))
+(assert (raises-error? (scale-float 1.0d0 (1+ most-positive-fixnum))
+                      floating-point-overflow))

diff --git a/version.lisp-expr b/version.lisp-expr
index 19e53bc..a2d1d54 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.12.30"
+"0.8.12.31"