0.8.3.25:

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

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 7a17b29..cf807c1 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
@@ -1340,10 +1342,10 @@
 ;;;; modular functions
 #.
 (collect ((forms))
-  (flet ((definition (name width pattern)
+  (flet ((definition (name lambda-list width pattern)
            ;; We rely on (SUBTYPEP `(UNSIGNED-BYTE ,WIDTH)
            ;;                      'BIGNUM-ELEMENT-TYPE)
-           `(defun ,name (x y)
+           `(defun ,name ,lambda-list
               (flet ((prepare-argument (x)
                        (declare (integer x))
                        (etypecase x
@@ -1351,10 +1353,15 @@
                          (bignum-element-type (logand x ,pattern))
                          (fixnum (logand x ,pattern))
                          (bignum (logand (%bignum-ref x 0) ,pattern)))))
-                (,name (prepare-argument x) (prepare-argument y))))))
-    (loop for info being each hash-value of sb!c::*modular-funs*
+                (,name ,@(loop for arg in lambda-list
+                               collect `(prepare-argument ,arg)))))))
+    (loop for infos being each hash-value of sb!c::*modular-funs*
           ;; FIXME: We need to process only "toplevel" functions
-          do (loop for (width . name) in info
+          unless (eq infos :good)
+          do (loop for info in infos
+                   for name = (sb!c::modular-fun-info-name info)
+                   and width = (sb!c::modular-fun-info-width info)
+                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
                    for pattern = (1- (ash 1 width))
-                   do (forms (definition name width pattern)))))
+                   do (forms (definition name lambda-list width pattern)))))
   `(progn ,@(forms)))