X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Ffloat.lisp;h=14c1a790599dd4fe4bcde5729cebcaaf703c01d6;hb=1c91b0bc7eb814af6a8c58a99a83a024716138e8;hp=4f411f20c275999b44aa73b4e33fc3e53df6f87a;hpb=ebc5e12a9792f2e53cf5561c249236dae4501ef4;p=sbcl.git

diff --git a/src/code/float.lisp b/src/code/float.lisp
index 4f411f2..14c1a79 100644
--- a/src/code/float.lisp
+++ b/src/code/float.lisp
@@ -45,7 +45,7 @@
   (make-long-float (logior (ash sign 15) exp)
 		   (ldb (byte 32 32) sig)
 		   (ldb (byte 32 0) sig)))
-					
+
 ) ; EVAL-WHEN
 
 ;;;; float parameters
@@ -56,12 +56,12 @@
 (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)
+(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 least-negative-double-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))
 
@@ -196,59 +196,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 +283,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 +311,10 @@
     #!+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."
+  2)
 
 ;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT