0.pre8.58:

[sbcl.git] / src / code / float.lisp

diff --git a/src/code/float.lisp b/src/code/float.lisp
index ef111ae..91bafe6 100644 (file)
--- 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
 ;;;; 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
 ;;;; 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")
 ;;;; files for more information.
 
 (in-package "SB!KERNEL")

-
-(file-comment
-  "$Header$")

 \f
 ;;;; utilities
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
 \f
 ;;;; 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))
 (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
   (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)
                               (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)))
 
   (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))
 (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)
 (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))
 (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)
 (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))
 (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)
 (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)))
 (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))
 (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)
 (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)))
 (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
 
 (defconstant single-float-epsilon
   (single-from-bits 0 (- sb!vm:single-float-bias

@@ -196,59 +196,60 @@
      (and (zerop (ldb sb!vm:long-float-exponent-byte (long-float-exp-bits x)))
          (not (zerop x))))))
 
      (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
 
 ;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the
 ;;; actual exponent (and hence how denormalized it is), otherwise we just

@@ -256,7 +257,7 @@
 #!-sb-fluid (declaim (maybe-inline float-precision))
 (defun float-precision (f)
   #!+sb-doc
 #!-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)
   Will be less than FLOAT-DIGITS if denormalized or zero."
   (macrolet ((frob (digits bias decode)
               `(cond ((zerop f) 0)

@@ -281,7 +282,7 @@
 
 (defun float-sign (float1 &optional (float2 (float 1 float1)))
   #!+sb-doc
 
 (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))
    float1 and, if float2 is given, has the same absolute value
    as float2."
   (declare (float float1 float2))

@@ -310,12 +311,17 @@
     #!+long-float
     ((long-float) sb!vm:long-float-digits)))
 
     #!+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
 
 \f
 ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT
 

@@ -361,7 +367,7 @@
          (t
           (values (logior sig sb!vm:single-float-hidden-bit) biased sign)))))
 
          (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)))
 (defun integer-decode-double-denorm (x)
   (declare (type double-float x))
   (let* ((high-bits (double-float-high-bits (abs x)))

@@ -393,7 +399,7 @@
                  (truly-the fixnum (- biased extra-bias))
                  sign)))))
 
                  (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))
 (defun integer-decode-double-float (x)
   (declare (double-float x))
   (let* ((abs (abs x))

@@ -472,7 +478,7 @@
 ;;; Dispatch to the correct type-specific i-d-f function.
 (defun integer-decode-float (x)
   #!+sb-doc
 ;;; 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
    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 +531,7 @@
                         bits))
                   biased sign)))))
 
                         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)
 (defun decode-double-denorm (x)
   (declare (double-float x))
   (multiple-value-bind (sig exp sign) (integer-decode-double-denorm x)

@@ -538,7 +544,7 @@
            (truly-the fixnum (+ exp sb!vm:double-float-digits))
            (float sign 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))
 (defun decode-double-float (x)
   (declare (double-float x))
   (let* ((abs (abs x))

@@ -597,7 +603,7 @@
 ;;; Dispatch to the appropriate type-specific function.
 (defun decode-float (f)
   #!+sb-doc
 ;;; 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.
    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 +653,10 @@
          (single-float (single-from-bits sign new-exp sig))
          (double-float (double-from-bits sign new-exp sig))))))))
 
          (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)
 (defun scale-float-maybe-overflow (x exp)
   (cond
    ((float-infinity-p x)

@@ -668,10 +675,10 @@
     (when (sb!vm:current-float-trap :inexact)
       (error 'floating-point-inexact :operation 'scale-float
             :operands (list x exp)))
     (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.
 
 ;;; Scale a single or double float, calling the correct over/underflow
 ;;; functions.

@@ -718,7 +725,7 @@
 ;;; Dispatch to the correct type-specific scale-float function.
 (defun scale-float (f ex)
   #!+sb-doc
 ;;; 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)
   of precision or overflow."
   (number-dispatch ((f float))
     ((single-float)

@@ -792,7 +799,7 @@
                 (let* ((bits (ash bits -1))
                        (len (integer-length bits)))
                   (cond ((> len digits)
                 (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)))))
                          (scale-float (floatit (ash bits -1)) (1+ scale)))
                         (t
                          (scale-float (floatit bits) scale)))))

@@ -812,7 +819,7 @@
            (let ((extra (- (integer-length fraction-and-guard) digits)))
              (declare (fixnum extra))
              (cond ((/= extra 1)
            (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)
                    ((oddp fraction-and-guard)
                     (return
                      (if (zerop rem)

@@ -827,9 +834,9 @@
            (incf scale)))))))
 
 #|
            (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
 
 ;;; 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 +868,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))
           (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)))
                     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)
          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)
                          res-hi)))
            (declare (type (unsigned-byte 31) res-hi res))
            (if (minusp hi-bits)