0.pre8.36:

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

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index fac1b02..34ad585 100644 (file)
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -194,9 +194,13 @@
       (if (minusp den)
          (values (- num) (- den))
          (values num den))
       (if (minusp den)
          (values (- num) (- den))
          (values num den))

-    (if (eql den 1)
-       num
-       (%make-ratio num den))))
+    (cond
+      ((eql den 0)
+       (error 'division-by-zero
+             :operands (list num den)
+             :operation 'build-ratio))
+      ((eql den 1) num)
+      (t (%make-ratio num den)))))

 
 ;;; Truncate X and Y, but bum the case where Y is 1.
 #!-sb-fluid (declaim (inline maybe-truncate))
 
 ;;; Truncate X and Y, but bum the case where Y is 1.
 #!-sb-fluid (declaim (inline maybe-truncate))

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

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

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

@@ -679,19 +686,20 @@
        (+ rem divisor)
        rem)))
 
        (+ rem divisor)
        rem)))
 

-(macrolet ((def-frob (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-frob ffloor floor
-    "Same as FLOOR, but returns first value as a float.")
-  (def-frob fceiling ceiling
-    "Same as CEILING, but returns first value as a float." )
-  (def-frob ftruncate truncate
-    "Same as TRUNCATE, but returns first value as a float.")
-  (def-frob 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
 

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

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

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

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

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

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

@@ -978,13 +992,13 @@
     (fixnum (lognot (truly-the fixnum number)))
     (bignum (bignum-logical-not number))))
 
     (fixnum (lognot (truly-the fixnum number)))
     (bignum (bignum-logical-not number))))
 

-(macrolet ((def-frob (name op big-op)
+(macrolet ((def (name op big-op)

             `(defun ,name (x y)
               (number-dispatch ((x integer) (y integer))
                 (bignum-cross-fixnum ,op ,big-op)))))
             `(defun ,name (x y)
               (number-dispatch ((x integer) (y integer))
                 (bignum-cross-fixnum ,op ,big-op)))))

-  (def-frob two-arg-and logand bignum-logical-and)
-  (def-frob two-arg-ior logior bignum-logical-ior)
-  (def-frob two-arg-xor logxor bignum-logical-xor))
+  (def two-arg-and logand bignum-logical-and)
+  (def two-arg-ior logior bignum-logical-ior)
+  (def two-arg-xor logxor bignum-logical-xor))

 
 (defun logcount (integer)
   #!+sb-doc
 
 (defun logcount (integer)
   #!+sb-doc

@@ -1214,7 +1228,7 @@
     (13 (boole 13 integer1 integer2))
     (14 (boole 14 integer1 integer2))
     (15 (boole 15 integer1 integer2))
     (13 (boole 13 integer1 integer2))
     (14 (boole 14 integer1 integer2))
     (15 (boole 15 integer1 integer2))

-    (t (error "~S is not of type (mod 16)." op))))
+    (t (error 'type-error :datum op :expected-type '(mod 16)))))

 \f
 ;;;; GCD and LCM
 
 \f
 ;;;; GCD and LCM
 

@@ -1315,10 +1329,10 @@
 \f
 ;;;; miscellaneous number predicates
 
 \f
 ;;;; miscellaneous number predicates
 

-(macrolet ((def-frob (name doc)
+(macrolet ((def (name doc)

             `(defun ,name (number) ,doc (,name number))))
             `(defun ,name (number) ,doc (,name number))))

-  (def-frob zerop "Is this number zero?")
-  (def-frob plusp "Is this real number strictly positive?")
-  (def-frob minusp "Is this real number strictly negative?")
-  (def-frob oddp "Is this integer odd?")
-  (def-frob evenp "Is this integer even?"))
+  (def zerop "Is this number zero?")
+  (def plusp "Is this real number strictly positive?")
+  (def minusp "Is this real number strictly negative?")
+  (def oddp "Is this integer odd?")
+  (def evenp "Is this integer even?"))