X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=cf807c11cd3a77d5352e73c36c6a7262017004fe;hb=835768a81dad03b7eb94c2058e234413ba066396;hp=e6ae2979c42237d0cc36df3d7613ec4de3f27a25;hpb=6e73f7320651975ce7cd8e72e2334041b7e80df1;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index e6ae297..cf807c1 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -211,10 +211,11 @@
 
 ;;;; 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."
+  (declare (ignore environment))
   (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)
-       (values 0 number))
+       (bignum-truncate (make-small-bignum 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)
-	(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
@@ -685,19 +688,20 @@
 	(+ 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.")
 
 ;;;; comparisons
 
@@ -1334,3 +1338,30 @@
   (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)
+           ;; 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)))