X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat.lisp;h=d5ea0b9c0dee95aa7de75cbf224469767418f150;hb=01044af1b8d69fc3899dc0417064c1512223223d;hp=bb60ed5607e0852d07f090a95f279b75c9847d26;hpb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;p=sbcl.git

diff --git a/src/code/float.lisp b/src/code/float.lisp
index bb60ed5..d5ea0b9 100644
--- 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
-;;;; 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
@@ -15,164 +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
@@ -195,59 +37,60 @@
      (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
@@ -281,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)))
@@ -312,11 +155,7 @@
 (defun float-radix (x)
   #!+sb-doc
   "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))
+  (declare (ignore x))
   2)
 
 ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT
@@ -363,7 +202,7 @@
 	  (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)))
@@ -395,7 +234,7 @@
 		  (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))
@@ -527,7 +366,7 @@
 			 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)
@@ -540,7 +379,7 @@
 	    (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))
@@ -673,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.