-;;;; 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
(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))
(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)
(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
(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)
- `(defun ,name (x)
- ,doc
- (number-dispatch ((x float))
- ((single-float)
- (let ((bits (single-float-bits x)))
- (and (> (ldb sb!vm:single-float-exponent-byte bits)
- sb!vm:single-float-normal-exponent-max)
- ,single)))
- ((double-float)
- (let ((hi (double-float-high-bits x))
- (lo (double-float-low-bits x)))
- (declare (ignorable lo))
- (and (> (ldb sb!vm:double-float-exponent-byte hi)
- sb!vm:double-float-normal-exponent-max)
- ,double)))
- #!+(and long-float x86)
- ((long-float)
- (let ((exp (long-float-exp-bits x))
- (hi (long-float-high-bits x))
- (lo (long-float-low-bits x)))
- (declare (ignorable lo))
- (and (> (ldb sb!vm:long-float-exponent-byte exp)
- sb!vm:long-float-normal-exponent-max)
- ,long)))))))
-
- (def-frob 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))
- (zerop lo))
- #!+(and long-float x86)
- (and (zerop (ldb sb!vm:long-float-significand-byte hi))
- (zerop lo)))
-
- (def-frob 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)))
- (not (zerop lo)))
- #!+(and long-float x86)
- (or (not (zerop (ldb sb!vm:long-float-significand-byte hi)))
- (not (zerop lo))))
-
- (def-frob 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))
- (zerop (logand (ldb sb!vm:double-float-significand-byte hi)
- sb!vm:double-float-trapping-nan-bit))
- #!+(and long-float x86)
- (zerop (logand (ldb sb!vm:long-float-significand-byte hi)
- sb!vm:long-float-trapping-nan-bit))))
+(defmacro !define-float-dispatching-function
+ (name doc single double #!+(and long-float x86) long)
+ `(defun ,name (x)
+ ,doc
+ (number-dispatch ((x float))
+ ((single-float)
+ (let ((bits (single-float-bits x)))
+ (and (> (ldb sb!vm:single-float-exponent-byte bits)
+ sb!vm:single-float-normal-exponent-max)
+ ,single)))
+ ((double-float)
+ (let ((hi (double-float-high-bits x))
+ (lo (double-float-low-bits x)))
+ (declare (ignorable lo))
+ (and (> (ldb sb!vm:double-float-exponent-byte hi)
+ sb!vm:double-float-normal-exponent-max)
+ ,double)))
+ #!+(and long-float x86)
+ ((long-float)
+ (let ((exp (long-float-exp-bits x))
+ (hi (long-float-high-bits x))
+ (lo (long-float-low-bits x)))
+ (declare (ignorable lo))
+ (and (> (ldb sb!vm:long-float-exponent-byte exp)
+ sb!vm:long-float-normal-exponent-max)
+ ,long))))))
+
+(!define-float-dispatching-function 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))
+ (zerop lo))
+ #!+(and long-float x86)
+ (and (zerop (ldb sb!vm:long-float-significand-byte hi))
+ (zerop lo)))
+
+(!define-float-dispatching-function 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)))
+ (not (zerop lo)))
+ #!+(and long-float x86)
+ (or (not (zerop (ldb sb!vm:long-float-significand-byte hi)))
+ (not (zerop lo))))
+
+(!define-float-dispatching-function 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))
+ (zerop (logand (ldb sb!vm:double-float-significand-byte hi)
+ sb!vm:double-float-trapping-nan-bit))
+ #!+(and long-float x86)
+ (zerop (logand (ldb sb!vm:long-float-significand-byte hi)
+ sb!vm:long-float-trapping-nan-bit)))
;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the
;;; actual exponent (and hence how denormalized it is), otherwise we just
#!-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)
(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))
#!+long-float
((long-float) sb!vm:long-float-digits)))
-(defun float-radix (x)
- #!+sb-doc
- "Returns (as an integer) the radix b of its floating-point
- argument."
- (declare (type float x) (ignore x))
- 2)
+(setf (fdefinition 'float-radix)
+ ;; FIXME: Python flushes unused variable X in CLAMBDA, then
+ ;; flushes unused reference to X in XEP together with type
+ ;; check. When this is fixed, rewrite this definition in an
+ ;; ordinary form. -- APD, 2002-10-21
+ (lambda (x)
+ #!+sb-doc
+ "Return (as an integer) the radix b of its floating-point argument."
+ (unless (floatp x)
+ (error 'type-error :datum x :expected-type 'float))
+ 2))
\f
;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT
(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)))
(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))
;;; 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
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)
(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))
;;; 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.
(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)
(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.
;;; 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)
(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)))))
(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)
(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
(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)
projects / sbcl.git / blobdiff