X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat.lisp;h=d5ea0b9c0dee95aa7de75cbf224469767418f150;hb=56a972e201d117a8d5d769527f2bafd23cba7de9;hp=407b309be12fd4f5301bf518212c2dfaef35709a;hpb=f6f238261f95e8ffff2870ed3ac6fc00ddf09ef2;p=sbcl.git diff --git a/src/code/float.lisp b/src/code/float.lisp index 407b309..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 (double-from-bits 0 0 1)) -#!+(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 (double-from-bits 1 0 1)) -#!+(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 @@ -671,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.