0.7.0.2:

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

diff --git a/src/code/float.lisp b/src/code/float.lisp
index cd661ae..104818c 100644 (file)
--- a/src/code/float.lisp
+++ b/src/code/float.lisp
@@ -19,9 +19,10 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
 
 (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))

@@ -117,34 +118,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

@@ -193,7 +195,7 @@
      (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)
+(macrolet ((def (name doc single double #!+(and long-float x86) long)

             `(defun ,name (x)
                ,doc
                (number-dispatch ((x float))
             `(defun ,name (x)
                ,doc
                (number-dispatch ((x float))

@@ -219,7 +221,7 @@
                             sb!vm:long-float-normal-exponent-max)
                          ,long)))))))
 
                             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))
     "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))

@@ -228,7 +230,7 @@
     (and (zerop (ldb sb!vm:long-float-significand-byte hi))
         (zerop lo)))
 
     (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)))
     "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)))

@@ -237,7 +239,7 @@
     (or (not (zerop (ldb sb!vm:long-float-significand-byte hi)))
        (not (zerop lo))))
 
     (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))
     "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))

@@ -253,7 +255,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)

@@ -278,7 +280,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))

@@ -309,9 +311,12 @@
 
 (defun float-radix (x)
   #!+sb-doc
 
 (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)
 \f
 ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT
   2)
 \f
 ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT

@@ -469,7 +474,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

@@ -594,7 +599,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.

@@ -644,9 +649,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)

@@ -665,10 +671,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.

@@ -715,7 +721,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)

@@ -824,9 +830,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

@@ -858,19 +864,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)