0.8.2.32:

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

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 18fe19e..ff3e6d5 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)

@@ -323,9 +324,11 @@
             `(defun ,op (&rest args)
                #!+sb-doc ,doc
                (if (null args) ,init
             `(defun ,op (&rest args)
                #!+sb-doc ,doc
                (if (null args) ,init

-                 (do ((args (cdr args) (cdr args))
-                      (res (car args) (,op res (car args))))
-                     ((null args) res))))))
+                   (do ((args (cdr args) (cdr args))
+                        (result (car args) (,op result (car args))))
+                       ((null args) result)
+                     ;; to signal TYPE-ERROR when exactly 1 arg of wrong type:
+                     (declare (type number result)))))))

   (define-arith + 0
     "Return the sum of its arguments. With no args, returns 0.")
   (define-arith * 1
   (define-arith + 0
     "Return the sum of its arguments. With no args, returns 0.")
   (define-arith * 1

@@ -409,7 +412,7 @@
                                (nd (if (eql t2 1) t3 (* t2 t3))))
                           (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
 
                                (nd (if (eql t2 1) t3 (* t2 t3))))
                           (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
 

-); Eval-When (Compile)
+) ; EVAL-WHEN

 
 (two-arg-+/- two-arg-+ + add-bignums)
 (two-arg-+/- two-arg-- - subtract-bignum)
 
 (two-arg-+/- two-arg-+ + add-bignums)
 (two-arg-+/- two-arg-- - subtract-bignum)

@@ -683,19 +686,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
 

@@ -763,6 +767,7 @@
        (result number))
       ((null nlist) (return result))
      (declare (list nlist))
        (result number))
       ((null nlist) (return result))
      (declare (list nlist))

+     (declare (type real number result))

      (if (> (car nlist) result) (setq result (car nlist)))))
 
 (defun min (number &rest more-numbers)
      (if (> (car nlist) result) (setq result (car nlist)))))
 
 (defun min (number &rest more-numbers)

@@ -772,6 +777,7 @@
        (result number))
       ((null nlist) (return result))
      (declare (list nlist))
        (result number))
       ((null nlist) (return result))
      (declare (list nlist))

+     (declare (type real number result))

      (if (< (car nlist) result) (setq result (car nlist)))))
 
 (eval-when (:compile-toplevel :execute)
      (if (< (car nlist) result) (setq result (car nlist)))))
 
 (eval-when (:compile-toplevel :execute)

@@ -915,7 +921,8 @@
   (declare (list integers))
   (if integers
       (do ((result (pop integers) (logior result (pop integers))))
   (declare (list integers))
   (if integers
       (do ((result (pop integers) (logior result (pop integers))))

-         ((null integers) result))
+         ((null integers) result)
+       (declare (integer result)))

       0))
 
 (defun logxor (&rest integers)
       0))
 
 (defun logxor (&rest integers)

@@ -924,7 +931,8 @@
   (declare (list integers))
   (if integers
       (do ((result (pop integers) (logxor result (pop integers))))
   (declare (list integers))
   (if integers
       (do ((result (pop integers) (logxor result (pop integers))))

-         ((null integers) result))
+         ((null integers) result)
+       (declare (integer result)))

       0))
 
 (defun logand (&rest integers)
       0))
 
 (defun logand (&rest integers)

@@ -933,7 +941,8 @@
   (declare (list integers))
   (if integers
       (do ((result (pop integers) (logand result (pop integers))))
   (declare (list integers))
   (if integers
       (do ((result (pop integers) (logand result (pop integers))))

-         ((null integers) result))
+         ((null integers) result)
+       (declare (integer result)))

       -1))
 
 (defun logeqv (&rest integers)
       -1))
 
 (defun logeqv (&rest integers)

@@ -942,7 +951,8 @@
   (declare (list integers))
   (if integers
       (do ((result (pop integers) (logeqv result (pop integers))))
   (declare (list integers))
   (if integers
       (do ((result (pop integers) (logeqv result (pop integers))))

-         ((null integers) result))
+         ((null integers) result)
+       (declare (integer result)))

       -1))
 
 (defun lognand (integer1 integer2)
       -1))
 
 (defun lognand (integer1 integer2)

@@ -1326,3 +1336,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)
+           ;; We rely on (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)))