X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=7a644b38833fa6c5d6ecdab41d5954e4c9e6fc72;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=9eb5d54911f2309a46c7341d14139cbc3b9aeabd;hpb=85bc4001453f09c80c4b9662dd5cf23f0b1fbaed;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 9eb5d54..7a644b3 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -194,9 +194,13 @@
       (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))
@@ -207,24 +211,6 @@
 
 ;;;; COMPLEXes
 
-(defun upgraded-complex-part-type (spec)
-  #!+sb-doc
-  "Return the element type of the most specialized COMPLEX number type that
-   can hold parts of type SPEC."
-  (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."
@@ -279,7 +265,7 @@
     ((complex rational)
      (sb!kernel:%imagpart number))
     (float
-     (float 0 number))
+     (* 0 number))
     (t
      0)))
 
@@ -319,9 +305,11 @@
 	     `(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
@@ -405,7 +393,7 @@
 				(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)
@@ -571,7 +559,7 @@
 			  (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))))
@@ -647,19 +635,21 @@
   (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
@@ -679,25 +669,80 @@
 	(+ 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))))
+
+(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)))
 
 ;;;; 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)
      (declare (list nlist))
@@ -706,7 +751,7 @@
 (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))
@@ -719,7 +764,7 @@
 (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))
@@ -728,7 +773,7 @@
 (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))
@@ -737,7 +782,7 @@
 (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))
@@ -746,7 +791,7 @@
 (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))
@@ -754,20 +799,24 @@
 
 (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))
      (declare (list nlist))
+     (declare (type real number result))
      (if (> (car nlist) result) (setq result (car nlist)))))
 
 (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 (list nlist))
+     (declare (type real number result))
      (if (< (car nlist) result) (setq result (car nlist)))))
 
 (eval-when (:compile-toplevel :execute)
@@ -911,7 +960,8 @@
   (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)
@@ -920,7 +970,8 @@
   (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)
@@ -929,7 +980,8 @@
   (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)
@@ -938,39 +990,10 @@
   (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)
-  #!+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."
@@ -978,13 +1001,39 @@
     (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-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
@@ -992,8 +1041,9 @@
   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))))
@@ -1008,7 +1058,12 @@
 (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
@@ -1247,7 +1302,20 @@
 
 (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
@@ -1255,8 +1323,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)
-  (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)
@@ -1322,3 +1390,45 @@
   (def minusp "Is this real number strictly negative?")
   (def oddp "Is this integer odd?")
   (def evenp "Is this integer even?"))
+
+;;;; modular functions
+#.
+(collect ((forms))
+  (flet ((definition (name lambda-list width pattern)
+           `(defun ,name ,lambda-list
+              (flet ((prepare-argument (x)
+                       (declare (integer x))
+                       (etypecase x
+                         ((unsigned-byte ,width) x)
+                         (fixnum (logand x ,pattern))
+                         (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*
+          ;; 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)
+                   for pattern = (1- (ash 1 width))
+                   do (forms (definition name lambda-list width pattern)))))
+  `(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-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-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)
+		 (ash (logand integer #xffffffffffffffff) amount)))))