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 e6ae297..3632cd6 100644 (file)
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -211,10 +211,11 @@
 \f
 ;;;; COMPLEXes
 
 \f
 ;;;; COMPLEXes
 

-(defun upgraded-complex-part-type (spec)
+(defun upgraded-complex-part-type (spec &optional environment)

   #!+sb-doc
   "Return the element type of the most specialized COMPLEX number type that
    can hold parts of type SPEC."
   #!+sb-doc
   "Return the element type of the most specialized COMPLEX number type that
    can hold parts of type SPEC."

+  (declare (ignore environment))

   (cond ((unknown-type-p (specifier-type spec))
         (error "undefined type: ~S" spec))
        ((subtypep spec 'single-float)
   (cond ((unknown-type-p (specifier-type spec))
         (error "undefined type: ~S" spec))
        ((subtypep spec 'single-float)

@@ -577,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))))

@@ -653,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

@@ -685,19 +688,20 @@
        (+ rem divisor)
        rem)))
 
        (+ rem divisor)
        rem)))
 

-(macrolet ((def (name op doc)
-            `(defun ,name (number &optional (divisor 1))
-               ,doc
-               (multiple-value-bind (res rem) (,op number divisor)
-                 (values (float res (if (floatp rem) rem 1.0)) rem)))))
-  (def ffloor floor
-    "Same as FLOOR, but returns first value as a float.")
-  (def fceiling ceiling
-    "Same as CEILING, but returns first value as a float." )
-  (def ftruncate truncate
-    "Same as TRUNCATE, but returns first value as a float.")
-  (def fround round
-    "Same as ROUND, but returns first value as a float."))
+(defmacro !define-float-rounding-function (name op doc)
+  `(defun ,name (number &optional (divisor 1))
+    ,doc
+    (multiple-value-bind (res rem) (,op number divisor)
+      (values (float res (if (floatp rem) rem 1.0)) rem))))
+
+(!define-float-rounding-function ffloor floor
+  "Same as FLOOR, but returns first value as a float.")
+(!define-float-rounding-function fceiling ceiling
+  "Same as CEILING, but returns first value as a float." )
+(!define-float-rounding-function ftruncate truncate
+  "Same as TRUNCATE, but returns first value as a float.")
+(!define-float-rounding-function fround round
+  "Same as ROUND, but returns first value as a float.")

 \f
 ;;;; comparisons
 
 \f
 ;;;; comparisons
 

@@ -953,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."

@@ -990,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

@@ -1004,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))))

@@ -1020,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

@@ -1259,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

@@ -1267,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)

@@ -1334,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)))