0.8.3.45.modular1:

[sbcl.git] / src / code / numbers.lisp

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index ff3e6d5..f3adc3b 100644 (file)
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -578,7 +578,7 @@
                          (numerator divisor))))
         (values q (- number (* q divisor)))))
       ((fixnum bignum)
-       (values 0 number))
+       (bignum-truncate (make-small-bignum number) divisor))
       ((ratio (or float rational))
        (let ((q (truncate (numerator number)
                          (* (denominator number) divisor))))
@@ -654,19 +654,21 @@
   (if (eql divisor 1)
       (round number)
       (multiple-value-bind (tru rem) (truncate number divisor)
-       (let ((thresh (/ (abs divisor) 2)))
-         (cond ((or (> rem thresh)
-                    (and (= rem thresh) (oddp tru)))
-                (if (minusp divisor)
-                    (values (- tru 1) (+ rem divisor))
-                    (values (+ tru 1) (- rem divisor))))
-               ((let ((-thresh (- thresh)))
-                  (or (< rem -thresh)
-                      (and (= rem -thresh) (oddp tru))))
-                (if (minusp divisor)
-                    (values (+ tru 1) (- rem divisor))
-                    (values (- tru 1) (+ rem divisor))))
-               (t (values tru rem)))))))
+       (if (zerop rem)
+           (values tru rem)
+           (let ((thresh (/ (abs divisor) 2)))
+             (cond ((or (> rem thresh)
+                        (and (= rem thresh) (oddp tru)))
+                    (if (minusp divisor)
+                        (values (- tru 1) (+ rem divisor))
+                        (values (+ tru 1) (- rem divisor))))
+                   ((let ((-thresh (- thresh)))
+                      (or (< rem -thresh)
+                          (and (= rem -thresh) (oddp tru))))
+                    (if (minusp divisor)
+                        (values (+ tru 1) (- rem divisor))
+                        (values (- tru 1) (+ rem divisor))))
+                   (t (values tru rem))))))))
 
 (defun rem (number divisor)
   #!+sb-doc
@@ -955,36 +957,6 @@
        (declare (integer result)))
       -1))
 
-(defun lognand (integer1 integer2)
-  #!+sb-doc
-  "Return the complement of the logical AND of integer1 and integer2."
-  (lognand integer1 integer2))
-
-(defun lognor (integer1 integer2)
-  #!+sb-doc
-  "Return the complement of the logical OR of integer1 and integer2."
-  (lognor integer1 integer2))
-
-(defun logandc1 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical AND of (LOGNOT integer1) and integer2."
-  (logandc1 integer1 integer2))
-
-(defun logandc2 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical AND of integer1 and (LOGNOT integer2)."
-  (logandc2 integer1 integer2))
-
-(defun logorc1 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical OR of (LOGNOT integer1) and integer2."
-  (logorc1 integer1 integer2))
-
-(defun logorc2 (integer1 integer2)
-  #!+sb-doc
-  "Return the logical OR of integer1 and (LOGNOT integer2)."
-  (logorc2 integer1 integer2))
-
 (defun lognot (number)
   #!+sb-doc
   "Return the bit-wise logical not of integer."
@@ -992,13 +964,39 @@
     (fixnum (lognot (truly-the fixnum number)))
     (bignum (bignum-logical-not number))))
 
-(macrolet ((def (name op big-op)
-            `(defun ,name (x y)
-              (number-dispatch ((x integer) (y integer))
-                (bignum-cross-fixnum ,op ,big-op)))))
+(macrolet ((def (name op big-op &optional doc)
+            `(defun ,name (integer1 integer2)
+               ,@(when doc
+                   (list doc))
+               (let ((x integer1)
+                     (y integer2))
+                 (number-dispatch ((x integer) (y integer))
+                   (bignum-cross-fixnum ,op ,big-op))))))
   (def two-arg-and logand bignum-logical-and)
   (def two-arg-ior logior bignum-logical-ior)
-  (def two-arg-xor logxor bignum-logical-xor))
+  (def two-arg-xor logxor bignum-logical-xor)
+  ;; BIGNUM-LOGICAL-{AND,IOR,XOR} need not return a bignum, so must
+  ;; call the generic LOGNOT...
+  (def two-arg-eqv logeqv (lambda (x y) (lognot (bignum-logical-xor x y))))
+  (def lognand lognand 
+       (lambda (x y) (lognot (bignum-logical-and x y))) 
+       #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
+  (def lognor lognor
+       (lambda (x y) (lognot (bignum-logical-ior x y)))
+       #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
+  ;; ... but BIGNUM-LOGICAL-NOT on a bignum will always return a bignum
+  (def logandc1 logandc1
+       (lambda (x y) (bignum-logical-and (bignum-logical-not x) y))
+       #!+sb-doc "Bitwise AND (LOGNOT INTEGER1) with INTEGER2.")
+  (def logandc2 logandc2
+       (lambda (x y) (bignum-logical-and x (bignum-logical-not y)))
+       #!+sb-doc "Bitwise AND INTEGER1 with (LOGNOT INTEGER2).")
+  (def logorc1 logorc1
+       (lambda (x y) (bignum-logical-ior (bignum-logical-not x) y))
+       #!+sb-doc "Bitwise OR (LOGNOT INTEGER1) with INTEGER2.")
+  (def logorc2 logorc2
+       (lambda (x y) (bignum-logical-ior x (bignum-logical-not y)))
+       #!+sb-doc "Bitwise OR INTEGER1 with (LOGNOT INTEGER2)."))
 
 (defun logcount (integer)
   #!+sb-doc
@@ -1261,7 +1259,13 @@
 
 (defun two-arg-lcm (n m)
   (declare (integer n m))
-  (* (truncate (max n m) (gcd n m)) (min n m)))
+  (let ((m (abs m))
+        (n (abs n)))
+    (multiple-value-bind (max min)
+        (if (> m n)
+            (values m n)
+            (values n m))
+      (* (truncate max (gcd n m)) min))))
 
 ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
 ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
@@ -1269,8 +1273,8 @@
 ;;; of 0 before the dispatch so that the bignum code doesn't have to worry
 ;;; about "small bignum" zeros.
 (defun two-arg-gcd (u v)
-  (cond ((eql u 0) v)
-       ((eql v 0) u)
+  (cond ((eql u 0) (abs v))
+       ((eql v 0) (abs u))
        (t
         (number-dispatch ((u integer) (v integer))
           ((fixnum fixnum)