X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=31455e82de91b828e1be7147762c38fd79f8fb7b;hb=fb24d88c8f97f1b344addab398fc54f62d8aa4ce;hp=3ac83fac1b7f51dda8e12cf813d11f9c6c8d5eca;hpb=1907ad030ca773162bcd9ff90fdc485a035591f4;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 3ac83fa..31455e8 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -238,7 +238,7 @@
 (defun realpart (number)
   #!+sb-doc
   "Extract the real part of a number."
-  (typecase number
+  (etypecase number
     #!+long-float
     ((complex long-float)
      (truly-the long-float (realpart number)))
@@ -248,13 +248,13 @@
      (truly-the single-float (realpart number)))
     ((complex rational)
      (sb!kernel:%realpart number))
-    (t
+    (number
      number)))
 
 (defun imagpart (number)
   #!+sb-doc
   "Extract the imaginary part of a number."
-  (typecase number
+  (etypecase number
     #!+long-float
     ((complex long-float)
      (truly-the long-float (imagpart number)))
@@ -266,13 +266,14 @@
      (sb!kernel:%imagpart number))
     (float
      (* 0 number))
-    (t
+    (number
      0)))
 
 (defun conjugate (number)
   #!+sb-doc
   "Return the complex conjugate of NUMBER. For non-complex numbers, this is
   an identity."
+  (declare (type number number))
   (if (complexp number)
       (complex (realpart number) (- (imagpart number)))
       number))
@@ -362,9 +363,9 @@
                            (,op (imagpart x) (imagpart y))))
        (((foreach bignum fixnum ratio single-float double-float
                   #!+long-float long-float) complex)
-        (complex (,op x (realpart y)) (,op (imagpart y))))
+        (complex (,op x (realpart y)) (,op 0 (imagpart y))))
        ((complex (or rational float))
-        (complex (,op (realpart x) y) (imagpart x)))
+        (complex (,op (realpart x) y) (,op (imagpart x) 0)))
 
        (((foreach fixnum bignum) ratio)
         (let* ((dy (denominator y))
@@ -742,7 +743,7 @@
 (defun = (number &rest more-numbers)
   #!+sb-doc
   "Return T if all of its arguments are numerically equal, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
+  (declare (truly-dynamic-extent more-numbers))
   (the number number)
   (do ((nlist more-numbers (cdr nlist)))
       ((atom nlist) t)
@@ -752,7 +753,7 @@
 (defun /= (number &rest more-numbers)
   #!+sb-doc
   "Return T if no two of its arguments are numerically equal, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
+  (declare (truly-dynamic-extent more-numbers))
   (do* ((head (the number number) (car nlist))
         (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
@@ -766,7 +767,7 @@
 (defun < (number &rest more-numbers)
   #!+sb-doc
   "Return T if its arguments are in strictly increasing order, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
+  (declare (truly-dynamic-extent more-numbers))
   (do* ((n (the number number) (car nlist))
         (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
@@ -776,7 +777,7 @@
 (defun > (number &rest more-numbers)
   #!+sb-doc
   "Return T if its arguments are in strictly decreasing order, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
+  (declare (truly-dynamic-extent more-numbers))
   (do* ((n (the number number) (car nlist))
         (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
@@ -786,7 +787,7 @@
 (defun <= (number &rest more-numbers)
   #!+sb-doc
   "Return T if arguments are in strictly non-decreasing order, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
+  (declare (truly-dynamic-extent more-numbers))
   (do* ((n (the number number) (car nlist))
         (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
@@ -796,7 +797,7 @@
 (defun >= (number &rest more-numbers)
   #!+sb-doc
   "Return T if arguments are in strictly non-increasing order, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
+  (declare (truly-dynamic-extent more-numbers))
   (do* ((n (the number number) (car nlist))
         (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
@@ -807,7 +808,7 @@
   #!+sb-doc
   "Return the greatest of its arguments; among EQUALP greatest, return
 the first."
-  (declare (dynamic-extent more-numbers))
+  (declare (truly-dynamic-extent more-numbers))
   (do ((nlist more-numbers (cdr nlist))
        (result number))
       ((null nlist) (return result))
@@ -819,7 +820,7 @@ the first."
   #!+sb-doc
   "Return the least of its arguments; among EQUALP least, return
 the first."
-  (declare (dynamic-extent more-numbers))
+  (declare (truly-dynamic-extent more-numbers))
   (do ((nlist more-numbers (cdr nlist))
        (result number))
       ((null nlist) (return result))
@@ -827,15 +828,6 @@ the first."
      (declare (type real number result))
      (if (< (car nlist) result) (setq result (car nlist)))))
 
-(defconstant most-positive-exactly-single-float-fixnum
-  (min #xffffff most-positive-fixnum))
-(defconstant most-negative-exactly-single-float-fixnum
-  (max #x-ffffff most-negative-fixnum))
-(defconstant most-positive-exactly-double-float-fixnum
-  (min #x1fffffffffffff most-positive-fixnum))
-(defconstant most-negative-exactly-double-float-fixnum
-  (max #x-1fffffffffffff most-negative-fixnum))
-
 (eval-when (:compile-toplevel :execute)
 
 ;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how
@@ -863,10 +855,10 @@ the first."
          ;; conversion.
          (multiple-value-bind (lo hi)
              (case '(dispatch-type y)
-               ('single-float
+               (single-float
                 (values most-negative-exactly-single-float-fixnum
                         most-positive-exactly-single-float-fixnum))
-               ('double-float
+               (double-float
                 (values most-negative-exactly-double-float-fixnum
                         most-positive-exactly-double-float-fixnum)))
            (if (<= lo y hi)
@@ -880,10 +872,10 @@ the first."
              ;; Likewise
              (multiple-value-bind (lo hi)
                  (case '(dispatch-type x)
-                   ('single-float
+                   (single-float
                     (values most-negative-exactly-single-float-fixnum
                             most-positive-exactly-single-float-fixnum))
-                   ('double-float
+                   (double-float
                     (values most-negative-exactly-double-float-fixnum
                             most-positive-exactly-double-float-fixnum)))
                (if (<= lo y hi)
@@ -1304,30 +1296,30 @@ the first."
 
 ;;;; GCD and LCM
 
-(defun gcd (&rest numbers)
+(defun gcd (&rest integers)
   #!+sb-doc
   "Return the greatest common divisor of the arguments, which must be
   integers. Gcd with no arguments is defined to be 0."
-  (cond ((null numbers) 0)
-        ((null (cdr numbers)) (abs (the integer (car numbers))))
+  (cond ((null integers) 0)
+        ((null (cdr integers)) (abs (the integer (car integers))))
         (t
-         (do ((gcd (the integer (car numbers))
+         (do ((gcd (the integer (car integers))
                    (gcd gcd (the integer (car rest))))
-              (rest (cdr numbers) (cdr rest)))
+              (rest (cdr integers) (cdr rest)))
              ((null rest) gcd)
            (declare (integer gcd)
                     (list rest))))))
 
-(defun lcm (&rest numbers)
+(defun lcm (&rest integers)
   #!+sb-doc
   "Return the least common multiple of one or more integers. LCM of no
   arguments is defined to be 1."
-  (cond ((null numbers) 1)
-        ((null (cdr numbers)) (abs (the integer (car numbers))))
+  (cond ((null integers) 1)
+        ((null (cdr integers)) (abs (the integer (car integers))))
         (t
-         (do ((lcm (the integer (car numbers))
+         (do ((lcm (the integer (car integers))
                    (lcm lcm (the integer (car rest))))
-              (rest (cdr numbers) (cdr rest)))
+              (rest (cdr integers) (cdr rest)))
              ((null rest) lcm)
            (declare (integer lcm) (list rest))))))
 
@@ -1340,6 +1332,10 @@ the first."
       ;; complicated way of writing the algorithm in the CLHS page for
       ;; LCM, and I don't know why.  To be investigated.  -- CSR,
       ;; 2003-09-11
+      ;;
+      ;;    It seems to me that this is written this way to avoid
+      ;;    unnecessary bignumification of intermediate results.
+      ;;        -- TCR, 2008-03-05
       (let ((m (abs m))
             (n (abs n)))
         (multiple-value-bind (max min)
@@ -1388,29 +1384,31 @@ the first."
            ((fixnum bignum)
             (bignum-gcd (make-small-bignum u) v))))))
 
-;;; From discussion on comp.lang.lisp and Akira Kurihara.
+;;;; from Robert Smith
 (defun isqrt (n)
   #!+sb-doc
   "Return the root of the nearest integer less than n which is a perfect
    square."
-  (declare (type unsigned-byte n) (values unsigned-byte))
-  ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
-  (if (and (fixnump n) (<= n 24))
-      (cond ((> n 15) 4)
-            ((> n  8) 3)
-            ((> n  3) 2)
-            ((> n  0) 1)
-            (t 0))
-      (let* ((n-len-quarter (ash (integer-length n) -2))
-             (n-half (ash n (- (ash n-len-quarter 1))))
-             (n-half-isqrt (isqrt n-half))
-             (init-value (ash (1+ n-half-isqrt) n-len-quarter)))
-        (loop
-          (let ((iterated-value
-                 (ash (+ init-value (truncate n init-value)) -1)))
-            (unless (< iterated-value init-value)
-              (return init-value))
-            (setq init-value iterated-value))))))
+  (declare (type unsigned-byte n))
+  (cond
+    ((> n 24)
+     (let* ((n-fourth-size (ash (1- (integer-length n)) -2))
+            (n-significant-half (ash n (- (ash n-fourth-size 1))))
+            (n-significant-half-isqrt (isqrt n-significant-half))
+            (zeroth-iteration (ash n-significant-half-isqrt n-fourth-size))
+            (qr (multiple-value-list (floor n zeroth-iteration)))
+            (first-iteration (ash (+ zeroth-iteration (first qr)) -1)))
+       (cond ((oddp (first qr))
+              first-iteration)
+             ((> (expt (- first-iteration zeroth-iteration) 2) (second qr))
+              (1- first-iteration))
+             (t
+              first-iteration))))
+    ((> n 15) 4)
+    ((> n  8) 3)
+    ((> n  3) 2)
+    ((> n  0) 1)
+    ((= n  0) 0)))
 
 ;;;; miscellaneous number predicates
 
@@ -1462,7 +1460,7 @@ the first."
       (do-mfuns sb!c::*untagged-unsigned-modular-class*)
       (do-mfuns sb!c::*untagged-signed-modular-class*)
       (do-mfuns sb!c::*tagged-modular-class*)))
-  `(progn ,@(forms)))
+  `(progn ,@(sort (forms) #'string< :key #'cadr)))
 
 ;;; KLUDGE: these out-of-line definitions can't use the modular
 ;;; arithmetic, as that is only (currently) defined for constant