0.8.3.82: Make the runtime compile (not necessarily run) on x86/bsd again

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

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 34ad585..3632cd6 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)
                          (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))))
       ((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)
   (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
 
 (defun rem (number divisor)
   #!+sb-doc

@@ -955,36 +957,6 @@
        (declare (integer result)))
       -1))
 
        (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."
 (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))))
 
     (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-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
 
 (defun logcount (integer)
   #!+sb-doc

@@ -1006,8 +1004,9 @@
   if INTEGER is negative."
   (etypecase integer
     (fixnum
   if INTEGER is negative."
   (etypecase integer
     (fixnum

-     (logcount (truly-the (integer 0 #.(max most-positive-fixnum
-                                           (lognot most-negative-fixnum)))
+     (logcount (truly-the (integer 0
+                                  #.(max sb!xc:most-positive-fixnum
+                                         (lognot sb!xc:most-negative-fixnum)))

                          (if (minusp (truly-the fixnum integer))
                              (lognot (truly-the fixnum integer))
                              integer))))
                          (if (minusp (truly-the fixnum integer))
                              (lognot (truly-the fixnum integer))
                              integer))))

@@ -1022,7 +1021,12 @@
 (defun logbitp (index integer)
   #!+sb-doc
   "Predicate returns T if bit index of integer is a 1."
 (defun logbitp (index integer)
   #!+sb-doc
   "Predicate returns T if bit index of integer is a 1."

-  (logbitp index integer))
+  (number-dispatch ((index integer) (integer integer))
+    ((fixnum fixnum) (if (> index #.(- sb!vm:n-word-bits sb!vm:n-lowtag-bits))
+                        (minusp integer)
+                        (not (zerop (logand integer (ash 1 index))))))
+    ((fixnum bignum) (bignum-logbitp index integer))
+    ((bignum (foreach fixnum bignum)) (minusp integer))))

 
 (defun ash (integer count)
   #!+sb-doc
 
 (defun ash (integer count)
   #!+sb-doc

@@ -1261,7 +1265,20 @@
 
 (defun two-arg-lcm (n m)
   (declare (integer n m))
 
 (defun two-arg-lcm (n m)
   (declare (integer n m))

-  (* (truncate (max n m) (gcd n m)) (min n m)))
+  (if (or (zerop n) (zerop m))
+      0
+      ;; KLUDGE: I'm going to assume that it was written this way
+      ;; originally for a reason.  However, this is a somewhat
+      ;; 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
+      (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
 
 ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
 ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly

@@ -1269,8 +1286,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)
 ;;; 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)
        (t
         (number-dispatch ((u integer) (v integer))
           ((fixnum fixnum)

@@ -1336,3 +1353,30 @@
   (def minusp "Is this real number strictly negative?")
   (def oddp "Is this integer odd?")
   (def evenp "Is this integer even?"))
   (def minusp "Is this real number strictly negative?")
   (def oddp "Is this integer odd?")
   (def evenp "Is this integer even?"))

+\f
+;;;; modular functions
+#.
+(collect ((forms))
+  (flet ((definition (name lambda-list width pattern)
+           (assert (sb!xc:subtypep `(unsigned-byte ,width)
+                                   'bignum-element-type))
+           `(defun ,name ,lambda-list
+              (flet ((prepare-argument (x)
+                       (declare (integer x))
+                       (etypecase x
+                         ((unsigned-byte ,width) x)
+                         (bignum-element-type (logand x ,pattern))
+                         (fixnum (logand x ,pattern))
+                         (bignum (logand (%bignum-ref x 0) ,pattern)))))
+                (,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
+          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 lambda-list width pattern)))))
+  `(progn ,@(forms)))