X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat.lisp;h=cc2b750968db13dd0c7d6612f5cc06c499c0a92a;hb=ea1fd7753b7dc1277a7d250fed317300fe1e5772;hp=ef111ae95259b249ef8ee892316c41c5b399450d;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/float.lisp b/src/code/float.lisp index ef111ae..cc2b750 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -1,7 +1,7 @@ -;;;; This file contains the definitions of float specific number +;;;; This file contains the definitions of float-specific number ;;;; support (other than irrational stuff, which is in irrat.) There is ;;;; code in here that assumes there are only two float formats: IEEE -;;;; single and double. (Long-float support has been added, but bugs +;;;; single and double. (LONG-FLOAT support has been added, but bugs ;;;; may still remain due to old code which assumes this dichotomy.) ;;;; This software is part of the SBCL system. See the README file for @@ -14,17 +14,15 @@ ;;;; files for more information. (in-package "SB!KERNEL") - -(file-comment - "$Header$") ;;;; utilities (eval-when (:compile-toplevel :load-toplevel :execute) -;;; These functions let us create floats from bits with the significand -;;; uniformly represented as an integer. This is less efficient for double -;;; floats, but is more convenient when making special values, etc. +;;; These functions let us create floats from bits with the +;;; significand uniformly represented as an integer. This is less +;;; efficient for double floats, but is more convenient when making +;;; special values, etc. (defun single-from-bits (sign exp sig) (declare (type bit sign) (type (unsigned-byte 24) sig) (type (unsigned-byte 8) exp)) @@ -36,7 +34,8 @@ (declare (type bit sign) (type (unsigned-byte 53) sig) (type (unsigned-byte 11) exp)) (make-double-float (dpb exp sb!vm:double-float-exponent-byte - (dpb (ash sig -32) sb!vm:double-float-significand-byte + (dpb (ash sig -32) + sb!vm:double-float-significand-byte (if (zerop sign) 0 -1))) (ldb (byte 32 0) sig))) #!+(and long-float x86) @@ -120,34 +119,35 @@ (long-from-bits 1 sb!vm:long-float-normal-exponent-max (ldb (byte sb!vm:long-float-digits 0) -1))) -#!+sb-infinities +;;; We don't want to do these DEFCONSTANTs at cross-compilation time, +;;; because the cross-compilation host might not support floating +;;; point infinities. Putting them inside a LET removes +;;; toplevel-formness, so that any EVAL-WHEN trickiness in the +;;; DEFCONSTANT forms is suppressed. +(let () (defconstant single-float-positive-infinity (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0)) -#!+sb-infinities (defconstant short-float-positive-infinity single-float-positive-infinity) -#!+sb-infinities (defconstant single-float-negative-infinity (single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0)) -#!+sb-infinities (defconstant short-float-negative-infinity single-float-negative-infinity) -#!+sb-infinities (defconstant double-float-positive-infinity (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0)) -#!+(and sb-infinities (not long-float)) +#!+(not long-float) (defconstant long-float-positive-infinity double-float-positive-infinity) -#!+(and sb-infinities long-float x86) +#!+(and long-float x86) (defconstant long-float-positive-infinity (long-from-bits 0 (1+ sb!vm:long-float-normal-exponent-max) (ash sb!vm:long-float-hidden-bit 32))) -#!+sb-infinities (defconstant double-float-negative-infinity (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0)) -#!+(and sb-infinities (not long-float)) +#!+(not long-float) (defconstant long-float-negative-infinity double-float-negative-infinity) -#!+(and sb-infinities long-float x86) +#!+(and long-float x86) (defconstant long-float-negative-infinity (long-from-bits 1 (1+ sb!vm:long-float-normal-exponent-max) (ash sb!vm:long-float-hidden-bit 32))) +) ; LET-to-suppress-possible-EVAL-WHENs (defconstant single-float-epsilon (single-from-bits 0 (- sb!vm:single-float-bias @@ -196,7 +196,7 @@ (and (zerop (ldb sb!vm:long-float-exponent-byte (long-float-exp-bits x))) (not (zerop x)))))) -(macrolet ((def-frob (name doc single double #!+(and long-float x86) long) +(macrolet ((def (name doc single double #!+(and long-float x86) long) `(defun ,name (x) ,doc (number-dispatch ((x float)) @@ -222,7 +222,7 @@ sb!vm:long-float-normal-exponent-max) ,long))))))) - (def-frob float-infinity-p + (def float-infinity-p "Return true if the float X is an infinity (+ or -)." (zerop (ldb sb!vm:single-float-significand-byte bits)) (and (zerop (ldb sb!vm:double-float-significand-byte hi)) @@ -231,7 +231,7 @@ (and (zerop (ldb sb!vm:long-float-significand-byte hi)) (zerop lo))) - (def-frob float-nan-p + (def float-nan-p "Return true if the float X is a NaN (Not a Number)." (not (zerop (ldb sb!vm:single-float-significand-byte bits))) (or (not (zerop (ldb sb!vm:double-float-significand-byte hi))) @@ -240,7 +240,7 @@ (or (not (zerop (ldb sb!vm:long-float-significand-byte hi))) (not (zerop lo)))) - (def-frob float-trapping-nan-p + (def float-trapping-nan-p "Return true if the float X is a trapping NaN (Not a Number)." (zerop (logand (ldb sb!vm:single-float-significand-byte bits) sb!vm:single-float-trapping-nan-bit)) @@ -256,7 +256,7 @@ #!-sb-fluid (declaim (maybe-inline float-precision)) (defun float-precision (f) #!+sb-doc - "Returns a non-negative number of significant digits in its float argument. + "Return a non-negative number of significant digits in its float argument. Will be less than FLOAT-DIGITS if denormalized or zero." (macrolet ((frob (digits bias decode) `(cond ((zerop f) 0) @@ -281,7 +281,7 @@ (defun float-sign (float1 &optional (float2 (float 1 float1))) #!+sb-doc - "Returns a floating-point number that has the same sign as + "Return a floating-point number that has the same sign as float1 and, if float2 is given, has the same absolute value as float2." (declare (float float1 float2)) @@ -312,9 +312,12 @@ (defun float-radix (x) #!+sb-doc - "Returns (as an integer) the radix b of its floating-point - argument." - (declare (type float x) (ignore x)) + "Return (as an integer) the radix b of its floating-point argument." + ;; ANSI says this function "should signal an error if [..] argument + ;; is not a float". Since X is otherwise ignored, Python doesn't + ;; check the type by default, so we have to do it ourself: + (unless (floatp x) + (error 'type-error :datum x :expected-type 'float)) 2) ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT @@ -361,7 +364,7 @@ (t (values (logior sig sb!vm:single-float-hidden-bit) biased sign))))) -;;; Like INTEGER-DECODE-SINGLE-DENORM, only doubly so. +;;; like INTEGER-DECODE-SINGLE-DENORM, only doubly so (defun integer-decode-double-denorm (x) (declare (type double-float x)) (let* ((high-bits (double-float-high-bits (abs x))) @@ -393,7 +396,7 @@ (truly-the fixnum (- biased extra-bias)) sign))))) -;;; Like INTEGER-DECODE-SINGLE-FLOAT, only doubly so. +;;; like INTEGER-DECODE-SINGLE-FLOAT, only doubly so (defun integer-decode-double-float (x) (declare (double-float x)) (let* ((abs (abs x)) @@ -472,7 +475,7 @@ ;;; Dispatch to the correct type-specific i-d-f function. (defun integer-decode-float (x) #!+sb-doc - "Returns three values: + "Return three values: 1) an integer representation of the significand. 2) the exponent for the power of 2 that the significand must be multiplied by to get the actual value. This differs from the DECODE-FLOAT exponent @@ -525,7 +528,7 @@ bits)) biased sign))))) -;;; Like DECODE-SINGLE-DENORM, only doubly so. +;;; like DECODE-SINGLE-DENORM, only doubly so (defun decode-double-denorm (x) (declare (double-float x)) (multiple-value-bind (sig exp sign) (integer-decode-double-denorm x) @@ -538,7 +541,7 @@ (truly-the fixnum (+ exp sb!vm:double-float-digits)) (float sign x)))) -;;; Like DECODE-SINGLE-FLOAT, only doubly so. +;;; like DECODE-SINGLE-FLOAT, only doubly so (defun decode-double-float (x) (declare (double-float x)) (let* ((abs (abs x)) @@ -597,7 +600,7 @@ ;;; Dispatch to the appropriate type-specific function. (defun decode-float (f) #!+sb-doc - "Returns three values: + "Return three values: 1) a floating-point number representing the significand. This is always between 0.5 (inclusive) and 1.0 (exclusive). 2) an integer representing the exponent. @@ -647,9 +650,10 @@ (single-float (single-from-bits sign new-exp sig)) (double-float (double-from-bits sign new-exp sig)))))))) -;;; Called when scaling a float overflows, or the original float was a NaN -;;; or infinity. If overflow errors are trapped, then error, otherwise return -;;; the appropriate infinity. If a NaN, signal or not as appropriate. +;;; Called when scaling a float overflows, or the original float was a +;;; NaN or infinity. If overflow errors are trapped, then error, +;;; otherwise return the appropriate infinity. If a NaN, signal or not +;;; as appropriate. (defun scale-float-maybe-overflow (x exp) (cond ((float-infinity-p x) @@ -668,10 +672,10 @@ (when (sb!vm:current-float-trap :inexact) (error 'floating-point-inexact :operation 'scale-float :operands (list x exp))) - (infinite (* (float-sign x) - (etypecase x - (single-float single-float-positive-infinity) - (double-float double-float-positive-infinity))))))) + (* (float-sign x) + (etypecase x + (single-float single-float-positive-infinity) + (double-float double-float-positive-infinity)))))) ;;; Scale a single or double float, calling the correct over/underflow ;;; functions. @@ -718,7 +722,7 @@ ;;; Dispatch to the correct type-specific scale-float function. (defun scale-float (f ex) #!+sb-doc - "Returns the value (* f (expt (float 2 f) ex)), but with no unnecessary loss + "Return the value (* f (expt (float 2 f) ex)), but with no unnecessary loss of precision or overflow." (number-dispatch ((f float)) ((single-float) @@ -792,7 +796,7 @@ (let* ((bits (ash bits -1)) (len (integer-length bits))) (cond ((> len digits) - (assert (= len (the fixnum (1+ digits)))) + (aver (= len (the fixnum (1+ digits)))) (scale-float (floatit (ash bits -1)) (1+ scale))) (t (scale-float (floatit bits) scale))))) @@ -812,7 +816,7 @@ (let ((extra (- (integer-length fraction-and-guard) digits))) (declare (fixnum extra)) (cond ((/= extra 1) - (assert (> extra 1))) + (aver (> extra 1))) ((oddp fraction-and-guard) (return (if (zerop rem) @@ -827,9 +831,9 @@ (incf scale))))))) #| -These might be useful if we ever have a machine w/o float/integer conversion -hardware. For now, we'll use special ops that uninterruptibly frob the -rounding modes & do ieee round-to-integer. +These might be useful if we ever have a machine without float/integer +conversion hardware. For now, we'll use special ops that +uninterruptibly frob the rounding modes & do ieee round-to-integer. ;;; The compiler compiles a call to this when we are doing %UNARY-TRUNCATE ;;; and the result is known to be a fixnum. We can avoid some generic @@ -861,19 +865,19 @@ rounding modes & do ieee round-to-integer. (exp (ldb sb!vm:double-float-exponent-byte hi-bits)) (frac (logior (ldb sb!vm:double-float-significand-byte hi-bits) sb!vm:double-float-hidden-bit)) - (shift (- exp (- sb!vm:double-float-digits sb!vm:word-bits) + (shift (- exp (- sb!vm:double-float-digits sb!vm:n-word-bits) sb!vm:double-float-bias))) (when (> exp sb!vm:double-float-normal-exponent-max) (error 'floating-point-invalid-operation :operator 'truncate :operands (list x))) - (if (<= shift (- sb!vm:word-bits sb!vm:double-float-digits)) + (if (<= shift (- sb!vm:n-word-bits sb!vm:double-float-digits)) 0 (let* ((res-hi (ash frac shift)) (res (if (plusp shift) (logior res-hi (the fixnum (ash (double-float-low-bits x) - (- shift sb!vm:word-bits)))) + (- shift sb!vm:n-word-bits)))) res-hi))) (declare (type (unsigned-byte 31) res-hi res)) (if (minusp hi-bits)