X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=ff3e6d5f3675f65f7478faf22819ff9d6d83ebeb;hb=1476586427d13b59571fa2c2a0d3836496b4c803;hp=18fe19eb6e9acd53eadc6761693bbbfc5f26e58c;hpb=bff8455d98c50672cdc29abcf1809b8823f5f117;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 18fe19e..ff3e6d5 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)
@@ -323,9 +324,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
@@ -409,7 +412,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)
@@ -683,19 +686,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
 
@@ -763,6 +767,7 @@
        (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)
@@ -772,6 +777,7 @@
        (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)
@@ -915,7 +921,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)
@@ -924,7 +931,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)
@@ -933,7 +941,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)
@@ -942,7 +951,8 @@
   (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)
@@ -1326,3 +1336,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)))