0.9.0.6:
[sbcl.git] / src / code / numbers.lisp
index a9987d6..d525b8a 100644 (file)
 \f
 ;;;; COMPLEXes
 
-(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."
-  (declare (ignore environment))
-  (cond ((unknown-type-p (specifier-type spec))
-        (error "undefined type: ~S" spec))
-       ((subtypep spec 'single-float)
-        'single-float)
-       ((subtypep spec 'double-float)
-        'double-float)
-       #!+long-float
-       ((subtypep spec 'long-float)
-        'long-float)
-       ((subtypep spec 'rational)
-        'rational)
-       (t
-        'real)))
-
 (defun complex (realpart &optional (imagpart 0))
   #!+sb-doc
   "Return a complex number with the specified real and imaginary components."
     ((complex rational)
      (sb!kernel:%imagpart number))
     (float
-     (float 0 number))
+     (* 0 number))
     (t
      0)))
 
                (cond ((eql t1 0) 0)
                      ((eql g2 1)
                       (%make-ratio t1 (* t2 dy)))
-                     (T (let* ((nn (truncate t1 g2))
+                     (t (let* ((nn (truncate t1 g2))
                                (t3 (truncate dy g2))
                                (nd (if (eql t2 1) t3 (* t2 t3))))
                           (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
     (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.")
+(defun ftruncate (number &optional (divisor 1))
+  #!+sb-doc
+  "Same as TRUNCATE, but returns first value as a float."
+  (macrolet ((ftruncate-float (rtype)
+              `(let* ((float-div (coerce divisor ',rtype))
+                      (res (%unary-ftruncate (/ number float-div))))
+                 (values res
+                         (- number
+                            (* (coerce res ',rtype) float-div))))))
+    (number-dispatch ((number real) (divisor real))
+      (((foreach fixnum bignum ratio) (or fixnum bignum ratio))
+       (multiple-value-bind (q r)
+          (truncate number divisor)
+        (values (float q) r)))
+      (((foreach single-float double-float #!+long-float long-float)
+       (or rational single-float))
+       (if (eql divisor 1)
+          (let ((res (%unary-ftruncate number)))
+            (values res (- number (coerce res '(dispatch-type number)))))
+          (ftruncate-float (dispatch-type number))))
+      #!+long-float
+      ((long-float (or single-float double-float long-float))
+       (ftruncate-float long-float))
+      #!+long-float
+      (((foreach double-float single-float) long-float)
+       (ftruncate-float long-float))
+      ((double-float (or single-float double-float))
+       (ftruncate-float double-float))
+      ((single-float double-float)
+       (ftruncate-float double-float))
+      (((foreach fixnum bignum ratio)
+       (foreach single-float double-float #!+long-float long-float))
+       (ftruncate-float (dispatch-type divisor))))))
+
+(defun ffloor (number &optional (divisor 1))
+  "Same as FLOOR, but returns first value as a float."
+  (multiple-value-bind (tru rem) (ftruncate number divisor)
+    (if (and (not (zerop rem))
+             (if (minusp divisor)
+                 (plusp number)
+                 (minusp number)))
+        (values (1- tru) (+ rem divisor))
+        (values tru rem))))
+
+(defun fceiling (number &optional (divisor 1))
+  "Same as CEILING, but returns first value as a float."
+  (multiple-value-bind (tru rem) (ftruncate number divisor)
+    (if (and (not (zerop rem))
+             (if (minusp divisor)
+                 (minusp number)
+                 (plusp number)))
+        (values (+ tru 1) (- rem divisor))
+        (values tru rem))))
+
+;;; FIXME: this probably needs treatment similar to the use of
+;;; %UNARY-FTRUNCATE for FTRUNCATE.
+(defun fround (number &optional (divisor 1))
+  "Same as ROUND, but returns first value as a float."
+  (multiple-value-bind (res rem)
+      (round number divisor)
+    (values (float res (if (floatp rem) rem 1.0)) rem)))
 \f
 ;;;; comparisons
 
 (defun = (number &rest more-numbers)
   #!+sb-doc
   "Return T if all of its arguments are numerically equal, NIL otherwise."
+  (the number number)
   (do ((nlist more-numbers (cdr nlist)))
-      ((atom nlist) T)
+      ((atom nlist) t)
      (declare (list nlist))
      (if (not (= (car nlist) number)) (return nil))))
 
 (defun /= (number &rest more-numbers)
   #!+sb-doc
   "Return T if no two of its arguments are numerically equal, NIL otherwise."
-  (do* ((head number (car nlist))
+  (do* ((head (the number number) (car nlist))
        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
      (unless (do* ((nl nlist (cdr nl)))
-                 ((atom nl) T)
+                 ((atom nl) t)
               (declare (list nl))
               (if (= head (car nl)) (return nil)))
        (return nil))))
 (defun < (number &rest more-numbers)
   #!+sb-doc
   "Return T if its arguments are in strictly increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
+  (do* ((n (the number number) (car nlist))
        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
 (defun > (number &rest more-numbers)
   #!+sb-doc
   "Return T if its arguments are in strictly decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
+  (do* ((n (the number number) (car nlist))
        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
 (defun <= (number &rest more-numbers)
   #!+sb-doc
   "Return T if arguments are in strictly non-decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
+  (do* ((n (the number number) (car nlist))
        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
 (defun >= (number &rest more-numbers)
   #!+sb-doc
   "Return T if arguments are in strictly non-increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
+  (do* ((n (the number number) (car nlist))
        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
 
 (defun max (number &rest more-numbers)
   #!+sb-doc
-  "Return the greatest of its arguments."
+  "Return the greatest of its arguments; among EQUALP greatest, return
+the first."
   (do ((nlist more-numbers (cdr nlist))
        (result number))
       ((null nlist) (return result))
 
 (defun min (number &rest more-numbers)
   #!+sb-doc
-  "Return the least of its arguments."
+  "Return the least of its arguments; among EQUALP least, return
+the first."
   (do ((nlist more-numbers (cdr nlist))
        (result number))
       ((null nlist) (return result))
      (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
     #!+long-float
     ((long-float (foreach single-float double-float))
      (,op x (coerce y 'long-float)))
+    ((fixnum (foreach single-float double-float))
+     (if (float-infinity-p y)
+         ,infinite-y-finite-x
+         ;; If the fixnum has an exact float representation, do a
+         ;; float comparison. Otherwise do the slow float -> ratio
+         ;; conversion.
+        (multiple-value-bind (lo hi)
+            (case '(dispatch-type y)
+              ('single-float
+               (values most-negative-exactly-single-float-fixnum
+                       most-positive-exactly-single-float-fixnum))
+              ('double-float
+               (values most-negative-exactly-double-float-fixnum
+                       most-positive-exactly-double-float-fixnum)))
+          (if (<= lo y hi)
+              (,op (coerce x '(dispatch-type y)) y)
+              (,op x (rational y))))))
+    (((foreach single-float double-float) fixnum)
+     (if (eql y 0)
+         (,op x (coerce 0 '(dispatch-type x)))
+         (if (float-infinity-p x)
+             ,infinite-x-finite-y
+             ;; Likewise
+            (multiple-value-bind (lo hi)
+                (case '(dispatch-type x)
+                  ('single-float
+                   (values most-negative-exactly-single-float-fixnum
+                           most-positive-exactly-single-float-fixnum))
+                  ('double-float
+                   (values most-negative-exactly-double-float-fixnum
+                           most-positive-exactly-double-float-fixnum)))
+              (if (<= lo y hi)
+                  (,op x (coerce y '(dispatch-type x)))
+                  (,op (rational x) y))))))
     (((foreach single-float double-float) double-float)
      (,op (coerce x 'double-float) y))
     ((double-float single-float)
 
 (defun integer-length (integer)
   #!+sb-doc
-  "Return the number of significant bits in the absolute value of integer."
+  "Return the number of non-sign bits in the twos-complement representation
+  of INTEGER."
   (etypecase integer
     (fixnum
      (integer-length (truly-the fixnum integer)))
   (let ((mask (ash (ldb (byte size 0) -1) posn)))
     (logior (logand newbyte mask)
            (logand integer (lognot mask)))))
+
+(defun sb!c::mask-signed-field (size integer)
+  #!+sb-doc
+  "Extract SIZE lower bits from INTEGER, considering them as a
+2-complement SIZE-bits representation of a signed integer."
+  (cond ((zerop size)
+         0)
+        ((logbitp (1- size) integer)
+         (dpb integer (byte size 0) -1))
+        (t
+         (ldb (byte size 0) integer))))
+
 \f
 ;;;; BOOLE
 
 (defun boole (op integer1 integer2)
   #!+sb-doc
   "Bit-wise boolean function on two integers. Function chosen by OP:
-       0       BOOLE-CLR
-       1       BOOLE-SET
-       2       BOOLE-1
-       3       BOOLE-2
-       4       BOOLE-C1
-       5       BOOLE-C2
-       6       BOOLE-AND
-       7       BOOLE-IOR
-       8       BOOLE-XOR
-       9       BOOLE-EQV
-       10      BOOLE-NAND
-       11      BOOLE-NOR
-       12      BOOLE-ANDC1
-       13      BOOLE-ANDC2
-       14      BOOLE-ORC1
-       15      BOOLE-ORC2"
+        0       BOOLE-CLR
+        1       BOOLE-SET
+        2       BOOLE-1
+        3       BOOLE-2
+        4       BOOLE-C1
+        5       BOOLE-C2
+        6       BOOLE-AND
+        7       BOOLE-IOR
+        8       BOOLE-XOR
+        9       BOOLE-EQV
+        10      BOOLE-NAND
+        11      BOOLE-NOR
+        12      BOOLE-ANDC1
+        13      BOOLE-ANDC2
+        14      BOOLE-ORC1
+        15      BOOLE-ORC2"
   (case op
     (0 (boole 0 integer1 integer2))
     (1 (boole 1 integer1 integer2))
                          (bignum (logand x ,pattern)))))
                 (,name ,@(loop for arg in lambda-list
                                collect `(prepare-argument ,arg)))))))
-    (loop for infos being each hash-value of sb!c::*modular-funs*
+    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*unsigned-modular-class*)
           ;; FIXME: We need to process only "toplevel" functions
-          unless (eq infos :good)
+          when (listp infos)
           do (loop for info in infos
                    for name = (sb!c::modular-fun-info-name info)
                    and width = (sb!c::modular-fun-info-width info)
                    do (forms (definition name lambda-list width pattern)))))
   `(progn ,@(forms)))
 
+#.
+(collect ((forms))
+  (flet ((definition (name lambda-list width)
+           `(defun ,name ,lambda-list
+              (flet ((prepare-argument (x)
+                       (declare (integer x))
+                       (etypecase x
+                         ((signed-byte ,width) x)
+                         (fixnum (sb!c::mask-signed-field ,width x))
+                         (bignum (sb!c::mask-signed-field ,width x)))))
+                (,name ,@(loop for arg in lambda-list
+                               collect `(prepare-argument ,arg)))))))
+    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
+          ;; FIXME: We need to process only "toplevel" functions
+          when (listp infos)
+          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)
+                   do (forms (definition name lambda-list width)))))
+  `(progn ,@(forms)))
+
 ;;; KLUDGE: these out-of-line definitions can't use the modular
 ;;; arithmetic, as that is only (currently) defined for constant
 ;;; shifts.  See also the comment in (LOGAND OPTIMIZER) for more
 ;;; discussion of this hack.  -- CSR, 2003-10-09
-#!-alpha
-(defun sb!vm::ash-left-constant-mod32 (integer amount)
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or))
+(defun sb!vm::ash-left-mod32 (integer amount)
   (etypecase integer
     ((unsigned-byte 32) (ldb (byte 32 0) (ash integer amount)))
     (fixnum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))
     (bignum (ldb (byte 32 0) (ash (logand integer #xffffffff) amount)))))
-#!+alpha
-(defun sb!vm::ash-left-constant-mod64 (integer amount)
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 64) '(and) '(or))
+(defun sb!vm::ash-left-mod64 (integer amount)
   (etypecase integer
     ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount)))
     (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
-    (bignum (ldb (byte 64 0) 
+    (bignum (ldb (byte 64 0)
                 (ash (logand integer #xffffffffffffffff) amount)))))
-    
+
+#!+x86
+(defun sb!vm::ash-left-smod30 (integer amount)
+  (etypecase integer
+    ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
+    (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))
+
+#!+x86-64
+(defun sb!vm::ash-left-smod61 (integer amount)
+  (etypecase integer
+    ((signed-byte 61) (sb!c::mask-signed-field 61 (ash integer amount)))
+    (integer (sb!c::mask-signed-field 61 (ash (sb!c::mask-signed-field 61 integer) amount)))))