(in-package "SB!KERNEL")
\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.
-(defun single-from-bits (sign exp sig)
- (declare (type bit sign) (type (unsigned-byte 24) sig)
- (type (unsigned-byte 8) exp))
- (make-single-float
- (dpb exp sb!vm:single-float-exponent-byte
- (dpb sig sb!vm:single-float-significand-byte
- (if (zerop sign) 0 -1)))))
-(defun double-from-bits (sign exp sig)
- (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
- (if (zerop sign) 0 -1)))
- (ldb (byte 32 0) sig)))
-#!+(and long-float x86)
-(defun long-from-bits (sign exp sig)
- (declare (type bit sign) (type (unsigned-byte 64) sig)
- (type (unsigned-byte 15) exp))
- (make-long-float (logior (ash sign 15) exp)
- (ldb (byte 32 32) sig)
- (ldb (byte 32 0) sig)))
-
-) ; EVAL-WHEN
-\f
-;;;; float parameters
-
-(defconstant least-positive-single-float (single-from-bits 0 0 1))
-(defconstant least-positive-short-float least-positive-single-float)
-(defconstant least-negative-single-float (single-from-bits 1 0 1))
-(defconstant least-negative-short-float least-negative-single-float)
-(defconstant least-positive-double-float (double-from-bits 0 0 1))
-#!-long-float
-(defconstant least-positive-long-float least-positive-double-float)
-#!+(and long-float x86)
-(defconstant least-positive-long-float (long-from-bits 0 0 1))
-(defconstant least-negative-double-float (double-from-bits 1 0 1))
-#!-long-float
-(defconstant least-negative-long-float least-negative-double-float)
-#!+(and long-float x86)
-(defconstant least-negative-long-float (long-from-bits 1 0 1))
-
-(defconstant least-positive-normalized-single-float
- (single-from-bits 0 sb!vm:single-float-normal-exponent-min 0))
-(defconstant least-positive-normalized-short-float
- least-positive-normalized-single-float)
-(defconstant least-negative-normalized-single-float
- (single-from-bits 1 sb!vm:single-float-normal-exponent-min 0))
-(defconstant least-negative-normalized-short-float
- least-negative-normalized-single-float)
-(defconstant least-positive-normalized-double-float
- (double-from-bits 0 sb!vm:double-float-normal-exponent-min 0))
-#!-long-float
-(defconstant least-positive-normalized-long-float
- least-positive-normalized-double-float)
-#!+(and long-float x86)
-(defconstant least-positive-normalized-long-float
- (long-from-bits 0 sb!vm:long-float-normal-exponent-min
- (ash sb!vm:long-float-hidden-bit 32)))
-(defconstant least-negative-normalized-double-float
- (double-from-bits 1 sb!vm:double-float-normal-exponent-min 0))
-#!-long-float
-(defconstant least-negative-normalized-long-float
- least-negative-normalized-double-float)
-#!+(and long-float x86)
-(defconstant least-negative-normalized-long-float
- (long-from-bits 1 sb!vm:long-float-normal-exponent-min
- (ash sb!vm:long-float-hidden-bit 32)))
-
-(defconstant most-positive-single-float
- (single-from-bits 0 sb!vm:single-float-normal-exponent-max
- (ldb sb!vm:single-float-significand-byte -1)))
-(defconstant most-positive-short-float most-positive-single-float)
-(defconstant most-negative-single-float
- (single-from-bits 1 sb!vm:single-float-normal-exponent-max
- (ldb sb!vm:single-float-significand-byte -1)))
-(defconstant most-negative-short-float most-negative-single-float)
-(defconstant most-positive-double-float
- (double-from-bits 0 sb!vm:double-float-normal-exponent-max
- (ldb (byte sb!vm:double-float-digits 0) -1)))
-#!-long-float
-(defconstant most-positive-long-float most-positive-double-float)
-#!+(and long-float x86)
-(defconstant most-positive-long-float
- (long-from-bits 0 sb!vm:long-float-normal-exponent-max
- (ldb (byte sb!vm:long-float-digits 0) -1)))
-(defconstant most-negative-double-float
- (double-from-bits 1 sb!vm:double-float-normal-exponent-max
- (ldb (byte sb!vm:double-float-digits 0) -1)))
-#!-long-float
-(defconstant most-negative-long-float most-negative-double-float)
-#!+(and long-float x86)
-(defconstant most-negative-long-float
- (long-from-bits 1 sb!vm:long-float-normal-exponent-max
- (ldb (byte sb!vm:long-float-digits 0) -1)))
-
-;;; 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 short-float-positive-infinity single-float-positive-infinity)
-(defconstant single-float-negative-infinity
- (single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0))
-(defconstant short-float-negative-infinity single-float-negative-infinity)
-(defconstant double-float-positive-infinity
- (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
-#!+(not long-float)
-(defconstant long-float-positive-infinity double-float-positive-infinity)
-#!+(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 double-float-negative-infinity
- (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0))
-#!+(not long-float)
-(defconstant long-float-negative-infinity double-float-negative-infinity)
-#!+(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
- (1- sb!vm:single-float-digits)) 1))
-(defconstant short-float-epsilon single-float-epsilon)
-(defconstant single-float-negative-epsilon
- (single-from-bits 0 (- sb!vm:single-float-bias sb!vm:single-float-digits) 1))
-(defconstant short-float-negative-epsilon single-float-negative-epsilon)
-(defconstant double-float-epsilon
- (double-from-bits 0 (- sb!vm:double-float-bias
- (1- sb!vm:double-float-digits)) 1))
-#!-long-float
-(defconstant long-float-epsilon double-float-epsilon)
-#!+(and long-float x86)
-(defconstant long-float-epsilon
- (long-from-bits 0 (- sb!vm:long-float-bias (1- sb!vm:long-float-digits))
- (+ 1 (ash sb!vm:long-float-hidden-bit 32))))
-(defconstant double-float-negative-epsilon
- (double-from-bits 0 (- sb!vm:double-float-bias sb!vm:double-float-digits) 1))
-#!-long-float
-(defconstant long-float-negative-epsilon double-float-negative-epsilon)
-#!+(and long-float x86)
-(defconstant long-float-negative-epsilon
- (long-from-bits 0 (- sb!vm:long-float-bias sb!vm:long-float-digits)
- (+ 1 (ash sb!vm:long-float-hidden-bit 32))))
-\f
;;;; float predicates and environment query
#!-sb-fluid
(and (zerop (ldb sb!vm:long-float-exponent-byte (long-float-exp-bits x)))
(not (zerop x))))))
-(macrolet ((def (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 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 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 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
(defun float-sign (float1 &optional (float2 (float 1 float1)))
#!+sb-doc
"Return a floating-point number that has the same sign as
- float1 and, if float2 is given, has the same absolute value
- as float2."
+ FLOAT1 and, if FLOAT2 is given, has the same absolute value
+ as FLOAT2."
(declare (float float1 float2))
(* (if (etypecase float1
(single-float (minusp (single-float-bits float1)))
#!+long-float
((long-float) sb!vm:long-float-digits)))
-(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))
+(defun float-radix (x)
+ #!+sb-doc
+ "Return (as an integer) the radix b of its floating-point argument."
+ (declare (ignore x))
+ 2)
\f
;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT
:operands (list x exp)))
(* (float-sign x)
(etypecase x
- (single-float single-float-positive-infinity)
- (double-float double-float-positive-infinity))))))
+ (single-float
+ ;; SINGLE-FLOAT-POSITIVE-INFINITY
+ (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0))
+ (double-float
+ ;; DOUBLE-FLOAT-POSITIVE-INFINITY
+ (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0)))))))
;;; Scale a single or double float, calling the correct over/underflow
;;; functions.
projects / sbcl.git / blobdiff