From a163c70e2bef35bf482a785dbfd9c545b4fcd555 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 14 Jul 2004 06:21:10 +0000 Subject: [PATCH] 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 --- BUGS | 3 -- NEWS | 2 ++ src/code/float.lisp | 74 +++++++++++++++++++++++------------------- src/compiler/float-tran.lisp | 4 +-- src/compiler/fndb.lisp | 2 +- tests/float.pure.lisp | 24 ++++++++++---- version.lisp-expr | 2 +- 7 files changed, 64 insertions(+), 47 deletions(-) diff --git a/BUGS b/BUGS index 10fb8d1..c382343 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4