X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat.lisp;h=d5ea0b9c0dee95aa7de75cbf224469767418f150;hb=01044af1b8d69fc3899dc0417064c1512223223d;hp=4f411f20c275999b44aa73b4e33fc3e53df6f87a;hpb=ebc5e12a9792f2e53cf5561c249236dae4501ef4;p=sbcl.git diff --git a/src/code/float.lisp b/src/code/float.lisp index 4f411f2..d5ea0b9 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -15,165 +15,6 @@ (in-package "SB!KERNEL") -;;;; 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 - -;;;; 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)))) - ;;;; float predicates and environment query #!-sb-fluid @@ -196,59 +37,60 @@ (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 @@ -282,8 +124,8 @@ (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))) @@ -310,17 +152,11 @@ #!+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) ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT @@ -676,8 +512,12 @@ :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.