X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=40706afca99c9b2b5ffc9c2fdb89c4eacf0b8edf;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=f3adc3bcae6d69661f5acbc65d70ac69d1b27d98;hpb=4b58efcd710097cf7cc9b1a1bed8b0e1bd6eb3b8;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index f3adc3b..40706af 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -21,29 +21,29 @@
 ;;; leaf is the body to be executed in that case.
 (defun parse-number-dispatch (vars result types var-types body)
   (cond ((null vars)
-	 (unless (null types) (error "More types than vars."))
-	 (when (cdr result)
-	   (error "Duplicate case: ~S." body))
-	 (setf (cdr result)
-	       (sublis var-types body :test #'equal)))
-	((null types)
-	 (error "More vars than types."))
-	(t
-	 (flet ((frob (var type)
-		  (parse-number-dispatch
-		   (rest vars)
-		   (or (assoc type (cdr result) :test #'equal)
-		       (car (setf (cdr result)
-				  (acons type nil (cdr result)))))
-		   (rest types)
-		   (acons `(dispatch-type ,var) type var-types)
-		   body)))
-	   (let ((type (first types))
-		 (var (first vars)))
-	     (if (and (consp type) (eq (first type) 'foreach))
-		 (dolist (type (rest type))
-		   (frob var type))
-		 (frob var type)))))))
+         (unless (null types) (error "More types than vars."))
+         (when (cdr result)
+           (error "Duplicate case: ~S." body))
+         (setf (cdr result)
+               (sublis var-types body :test #'equal)))
+        ((null types)
+         (error "More vars than types."))
+        (t
+         (flet ((frob (var type)
+                  (parse-number-dispatch
+                   (rest vars)
+                   (or (assoc type (cdr result) :test #'equal)
+                       (car (setf (cdr result)
+                                  (acons type nil (cdr result)))))
+                   (rest types)
+                   (acons `(dispatch-type ,var) type var-types)
+                   body)))
+           (let ((type (first types))
+                 (var (first vars)))
+             (if (and (consp type) (eq (first type) 'foreach))
+                 (dolist (type (rest type))
+                   (frob var type))
+                 (frob var type)))))))
 
 ;;; our guess for the preferred order in which to do type tests
 ;;; (cheaper and/or more probable first.)
@@ -54,26 +54,67 @@
 ;;; Should TYPE1 be tested before TYPE2?
 (defun type-test-order (type1 type2)
   (let ((o1 (position type1 *type-test-ordering*))
-	(o2 (position type2 *type-test-ordering*)))
+        (o2 (position type2 *type-test-ordering*)))
     (cond ((not o1) nil)
-	  ((not o2) t)
-	  (t
-	   (< o1 o2)))))
+          ((not o2) t)
+          (t
+           (< o1 o2)))))
 
 ;;; Return an ETYPECASE form that does the type dispatch, ordering the
 ;;; cases for efficiency.
+;;; Check for some simple to detect problematic cases where the caller
+;;; used types that are not disjoint and where this may lead to
+;;; unexpected behaviour of the generated form, for example making
+;;; a clause unreachable, and throw an error if such a case is found.
+;;; An example:
+;;;   (number-dispatch ((var1 integer) (var2 float))
+;;;     ((fixnum single-float) a)
+;;;     ((integer float) b))
+;;; Even though the types are not reordered here, the generated form,
+;;; basically
+;;;   (etypecase var1
+;;;     (fixnum (etypecase var2
+;;;               (single-float a)))
+;;;     (integer (etypecase var2
+;;;                (float b))))
+;;; would fail at runtime if given var1 fixnum and var2 double-float,
+;;; even though the second clause matches this signature. To catch
+;;; this earlier than runtime we throw an error already here.
 (defun generate-number-dispatch (vars error-tags cases)
   (if vars
       (let ((var (first vars))
-	    (cases (sort cases #'type-test-order :key #'car)))
-	`((typecase ,var
-	    ,@(mapcar (lambda (case)
-			`(,(first case)
-			  ,@(generate-number-dispatch (rest vars)
-						      (rest error-tags)
-						      (cdr case))))
-		      cases)
-	    (t (go ,(first error-tags))))))
+            (cases (sort cases #'type-test-order :key #'car)))
+        (flet ((error-if-sub-or-supertype (type1 type2)
+                 (when (or (subtypep type1 type2)
+                           (subtypep type2 type1))
+                   (error "Types not disjoint: ~S ~S." type1 type2)))
+               (error-if-supertype (type1 type2)
+                 (when (subtypep type2 type1)
+                   (error "Type ~S ordered before subtype ~S."
+                          type1 type2)))
+               (test-type-pairs (fun)
+                 ;; Apply FUN to all (ordered) pairs of types from the
+                 ;; cases.
+                 (mapl (lambda (cases)
+                         (when (cdr cases)
+                           (let ((type1 (caar cases)))
+                             (dolist (case (cdr cases))
+                               (funcall fun type1 (car case))))))
+                       cases)))
+          ;; For the last variable throw an error if a type is followed
+          ;; by a subtype, for all other variables additionally if a
+          ;; type is followed by a supertype.
+          (test-type-pairs (if (cdr vars)
+                               #'error-if-sub-or-supertype
+                               #'error-if-supertype)))
+        `((typecase ,var
+            ,@(mapcar (lambda (case)
+                        `(,(first case)
+                          ,@(generate-number-dispatch (rest vars)
+                                                      (rest error-tags)
+                                                      (cdr case))))
+                      cases)
+            (t (go ,(first error-tags))))))
       cases))
 
 ) ; EVAL-WHEN
@@ -92,40 +133,47 @@
 ;;; symbol. In this case, we apply the CAR of the form to the CDR and
 ;;; treat the result of the call as a list of cases. This process is
 ;;; not applied recursively.
+;;;
+;;; Be careful when using non-disjoint types in different cases for the
+;;; same variable. Some uses will behave as intended, others not, as the
+;;; variables are dispatched off sequentially and clauses are reordered
+;;; for efficiency. Some, but not all, problematic cases are detected
+;;; and lead to a compile time error; see GENERATE-NUMBER-DISPATCH above
+;;; for an example.
 (defmacro number-dispatch (var-specs &body cases)
   (let ((res (list nil))
-	(vars (mapcar #'car var-specs))
-	(block (gensym)))
+        (vars (mapcar #'car var-specs))
+        (block (gensym)))
     (dolist (case cases)
       (if (symbolp (first case))
-	  (let ((cases (apply (symbol-function (first case)) (rest case))))
-	    (dolist (case cases)
-	      (parse-number-dispatch vars res (first case) nil (rest case))))
-	  (parse-number-dispatch vars res (first case) nil (rest case))))
+          (let ((cases (apply (symbol-function (first case)) (rest case))))
+            (dolist (case cases)
+              (parse-number-dispatch vars res (first case) nil (rest case))))
+          (parse-number-dispatch vars res (first case) nil (rest case))))
 
     (collect ((errors)
-	      (error-tags))
+              (error-tags))
       (dolist (spec var-specs)
-	(let ((var (first spec))
-	      (type (second spec))
-	      (tag (gensym)))
-	  (error-tags tag)
-	  (errors tag)
-	  (errors `(return-from
-		    ,block
-		    (error 'simple-type-error :datum ,var
-			   :expected-type ',type
-			   :format-control
-			   "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
-			   :format-arguments
-			   (list ',var ',type ,var))))))
+        (let ((var (first spec))
+              (type (second spec))
+              (tag (gensym)))
+          (error-tags tag)
+          (errors tag)
+          (errors `(return-from
+                    ,block
+                    (error 'simple-type-error :datum ,var
+                           :expected-type ',type
+                           :format-control
+                           "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
+                           :format-arguments
+                           (list ',var ',type ,var))))))
 
       `(block ,block
-	 (tagbody
-	   (return-from ,block
-			,@(generate-number-dispatch vars (error-tags)
-						    (cdr res)))
-	   ,@(errors))))))
+         (tagbody
+           (return-from ,block
+                        ,@(generate-number-dispatch vars (error-tags)
+                                                    (cdr res)))
+           ,@(errors))))))
 
 ;;;; binary operation dispatching utilities
 
@@ -173,17 +221,17 @@
   (if (eql imagpart 0)
       realpart
       (cond #!+long-float
-	    ((and (typep realpart 'long-float)
-		  (typep imagpart 'long-float))
-	     (truly-the (complex long-float) (complex realpart imagpart)))
-	    ((and (typep realpart 'double-float)
-		  (typep imagpart 'double-float))
-	     (truly-the (complex double-float) (complex realpart imagpart)))
-	    ((and (typep realpart 'single-float)
-		  (typep imagpart 'single-float))
-	     (truly-the (complex single-float) (complex realpart imagpart)))
-	    (t
-	     (%make-complex realpart imagpart)))))
+            ((and (typep realpart 'long-float)
+                  (typep imagpart 'long-float))
+             (truly-the (complex long-float) (complex realpart imagpart)))
+            ((and (typep realpart 'double-float)
+                  (typep imagpart 'double-float))
+             (truly-the (complex double-float) (complex realpart imagpart)))
+            ((and (typep realpart 'single-float)
+                  (typep imagpart 'single-float))
+             (truly-the (complex single-float) (complex realpart imagpart)))
+            (t
+             (%make-complex realpart imagpart)))))
 
 ;;; Given a numerator and denominator with the GCD already divided
 ;;; out, make a canonical rational. We make the denominator positive,
@@ -192,13 +240,13 @@
 (defun build-ratio (num den)
   (multiple-value-bind (num den)
       (if (minusp den)
-	  (values (- num) (- den))
-	  (values num den))
+          (values (- num) (- den))
+          (values num den))
     (cond
       ((eql den 0)
        (error 'division-by-zero
-	      :operands (list num den)
-	      :operation 'build-ratio))
+              :operands (list num den)
+              :operation 'build-ratio))
       ((eql den 1) num)
       (t (%make-ratio num den)))))
 
@@ -211,44 +259,25 @@
 
 ;;;; COMPLEXes
 
-(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)
-	 '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."
   (flet ((%%make-complex (realpart imagpart)
-	   (cond #!+long-float
-		 ((and (typep realpart 'long-float)
-		       (typep imagpart 'long-float))
-		  (truly-the (complex long-float)
-			     (complex realpart imagpart)))
-		 ((and (typep realpart 'double-float)
-		       (typep imagpart 'double-float))
-		  (truly-the (complex double-float)
-			     (complex realpart imagpart)))
-		 ((and (typep realpart 'single-float)
-		       (typep imagpart 'single-float))
-		  (truly-the (complex single-float)
-			     (complex realpart imagpart)))
-		 (t
-		  (%make-complex realpart imagpart)))))
+           (cond #!+long-float
+                 ((and (typep realpart 'long-float)
+                       (typep imagpart 'long-float))
+                  (truly-the (complex long-float)
+                             (complex realpart imagpart)))
+                 ((and (typep realpart 'double-float)
+                       (typep imagpart 'double-float))
+                  (truly-the (complex double-float)
+                             (complex realpart imagpart)))
+                 ((and (typep realpart 'single-float)
+                       (typep imagpart 'single-float))
+                  (truly-the (complex single-float)
+                             (complex realpart imagpart)))
+                 (t
+                  (%make-complex realpart imagpart)))))
   (number-dispatch ((realpart real) (imagpart real))
     ((rational rational)
      (canonical-complex realpart imagpart))
@@ -257,7 +286,7 @@
 (defun realpart (number)
   #!+sb-doc
   "Extract the real part of a number."
-  (typecase number
+  (etypecase number
     #!+long-float
     ((complex long-float)
      (truly-the long-float (realpart number)))
@@ -267,13 +296,13 @@
      (truly-the single-float (realpart number)))
     ((complex rational)
      (sb!kernel:%realpart number))
-    (t
+    (number
      number)))
 
 (defun imagpart (number)
   #!+sb-doc
   "Extract the imaginary part of a number."
-  (typecase number
+  (etypecase number
     #!+long-float
     ((complex long-float)
      (truly-the long-float (imagpart number)))
@@ -284,14 +313,15 @@
     ((complex rational)
      (sb!kernel:%imagpart number))
     (float
-     (float 0 number))
-    (t
+     (* 0 number))
+    (number
      0)))
 
 (defun conjugate (number)
   #!+sb-doc
   "Return the complex conjugate of NUMBER. For non-complex numbers, this is
   an identity."
+  (declare (type number number))
   (if (complexp number)
       (complex (realpart number) (- (imagpart number)))
       number))
@@ -302,8 +332,8 @@
   (if (zerop number)
       number
       (if (rationalp number)
-	  (if (plusp number) 1 -1)
-	  (/ number (abs number)))))
+          (if (plusp number) 1 -1)
+          (/ number (abs number)))))
 
 ;;;; ratios
 
@@ -318,17 +348,27 @@
   (denominator number))
 
 ;;;; arithmetic operations
+;;;;
+;;;; IMPORTANT NOTE: Accessing &REST arguments with NTH is actually extremely
+;;;; efficient in SBCL, as is taking their LENGTH -- so this code is very
+;;;; clever instead of being charmingly naive. Please check that "obvious"
+;;;; improvements don't actually ruin performance.
+;;;;
+;;;; (Granted that the difference between very clever and charmingly naivve
+;;;; can sometimes be sliced exceedingly thing...)
 
 (macrolet ((define-arith (op init doc)
-	     #!-sb-doc (declare (ignore doc))
-	     `(defun ,op (&rest args)
-		#!+sb-doc ,doc
-		(if (null args) ,init
-		    (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)))))))
+             #!-sb-doc (declare (ignore doc))
+             `(defun ,op (&rest numbers)
+                #!+sb-doc
+                ,doc
+                (if numbers
+                    (do ((result (nth 0 numbers) (,op result (nth i numbers)))
+                         (i 1 (1+ i)))
+                        ((>= i (length numbers))
+                         result)
+                      (declare (number result)))
+                    ,init))))
   (define-arith + 0
     "Return the sum of its arguments. With no args, returns 0.")
   (define-arith * 1
@@ -336,14 +376,12 @@
 
 (defun - (number &rest more-numbers)
   #!+sb-doc
-  "Subtract the second and all subsequent arguments from the first; 
+  "Subtract the second and all subsequent arguments from the first;
   or with one argument, negate the first argument."
   (if more-numbers
-      (do ((nlist more-numbers (cdr nlist))
-	   (result number))
-	  ((atom nlist) result)
-	 (declare (list nlist))
-	 (setq result (- result (car nlist))))
+      (let ((result number))
+        (dotimes (i (length more-numbers) result)
+          (setf result (- result (nth i more-numbers)))))
       (- number)))
 
 (defun / (number &rest more-numbers)
@@ -351,11 +389,9 @@
   "Divide the first argument by each of the following arguments, in turn.
   With one argument, return reciprocal."
   (if more-numbers
-      (do ((nlist more-numbers (cdr nlist))
-	   (result number))
-	  ((atom nlist) result)
-	 (declare (list nlist))
-	 (setq result (/ result (car nlist))))
+      (let ((result number))
+        (dotimes (i (length more-numbers) result)
+          (setf result (/ result (nth i more-numbers)))))
       (/ number)))
 
 (defun 1+ (number)
@@ -377,40 +413,40 @@
        (float-contagion ,op x y)
 
        ((complex complex)
-	(canonical-complex (,op (realpart x) (realpart y))
-			   (,op (imagpart x) (imagpart y))))
+        (canonical-complex (,op (realpart x) (realpart y))
+                           (,op (imagpart x) (imagpart y))))
        (((foreach bignum fixnum ratio single-float double-float
-		  #!+long-float long-float) complex)
-	(complex (,op x (realpart y)) (,op (imagpart y))))
+                  #!+long-float long-float) complex)
+        (complex (,op x (realpart y)) (,op 0 (imagpart y))))
        ((complex (or rational float))
-	(complex (,op (realpart x) y) (imagpart x)))
+        (complex (,op (realpart x) y) (,op (imagpart x) 0)))
 
        (((foreach fixnum bignum) ratio)
-	(let* ((dy (denominator y))
-	       (n (,op (* x dy) (numerator y))))
-	  (%make-ratio n dy)))
+        (let* ((dy (denominator y))
+               (n (,op (* x dy) (numerator y))))
+          (%make-ratio n dy)))
        ((ratio integer)
-	(let* ((dx (denominator x))
-	       (n (,op (numerator x) (* y dx))))
-	  (%make-ratio n dx)))
+        (let* ((dx (denominator x))
+               (n (,op (numerator x) (* y dx))))
+          (%make-ratio n dx)))
        ((ratio ratio)
-	(let* ((nx (numerator x))
-	       (dx (denominator x))
-	       (ny (numerator y))
-	       (dy (denominator y))
-	       (g1 (gcd dx dy)))
-	  (if (eql g1 1)
-	      (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
-	      (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
-		     (g2 (gcd t1 g1))
-		     (t2 (truncate dx g1)))
-		(cond ((eql t1 0) 0)
-		      ((eql g2 1)
-		       (%make-ratio t1 (* t2 dy)))
-		      (T (let* ((nn (truncate t1 g2))
-				(t3 (truncate dy g2))
-				(nd (if (eql t2 1) t3 (* t2 t3))))
-			   (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
+        (let* ((nx (numerator x))
+               (dx (denominator x))
+               (ny (numerator y))
+               (dy (denominator y))
+               (g1 (gcd dx dy)))
+          (if (eql g1 1)
+              (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
+              (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
+                     (g2 (gcd t1 g1))
+                     (t2 (truncate dx g1)))
+                (cond ((eql t1 0) 0)
+                      ((eql g2 1)
+                       (%make-ratio t1 (* t2 dy)))
+                      (t (let* ((nn (truncate t1 g2))
+                                (t3 (truncate dy g2))
+                                (nd (if (eql t2 1) t3 (* t2 t3))))
+                           (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
 
 ) ; EVAL-WHEN
 
@@ -419,19 +455,19 @@
 
 (defun two-arg-* (x y)
   (flet ((integer*ratio (x y)
-	   (if (eql x 0) 0
-	       (let* ((ny (numerator y))
-		      (dy (denominator y))
-		      (gcd (gcd x dy)))
-		 (if (eql gcd 1)
-		     (%make-ratio (* x ny) dy)
-		     (let ((nn (* (truncate x gcd) ny))
-			   (nd (truncate dy gcd)))
-		       (if (eql nd 1)
-			   nn
-			   (%make-ratio nn nd)))))))
-	 (complex*real (x y)
-	   (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
+           (if (eql x 0) 0
+               (let* ((ny (numerator y))
+                      (dy (denominator y))
+                      (gcd (gcd x dy)))
+                 (if (eql gcd 1)
+                     (%make-ratio (* x ny) dy)
+                     (let ((nn (* (truncate x gcd) ny))
+                           (nd (truncate dy gcd)))
+                       (if (eql nd 1)
+                           nn
+                           (%make-ratio nn nd)))))))
+         (complex*real (x y)
+           (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
     (number-dispatch ((x number) (y number))
       (float-contagion * x y)
 
@@ -442,13 +478,13 @@
 
       ((complex complex)
        (let* ((rx (realpart x))
-	      (ix (imagpart x))
-	      (ry (realpart y))
-	      (iy (imagpart y)))
-	 (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
+              (ix (imagpart x))
+              (ry (realpart y))
+              (iy (imagpart y)))
+         (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
       (((foreach bignum fixnum ratio single-float double-float
-		 #!+long-float long-float)
-	complex)
+                 #!+long-float long-float)
+        complex)
        (complex*real y x))
       ((complex (or rational float))
        (complex*real x y))
@@ -457,15 +493,15 @@
       ((ratio integer) (integer*ratio y x))
       ((ratio ratio)
        (let* ((nx (numerator x))
-	      (dx (denominator x))
-	      (ny (numerator y))
-	      (dy (denominator y))
-	      (g1 (gcd nx dy))
-	      (g2 (gcd dx ny)))
-	 (build-ratio (* (maybe-truncate nx g1)
-			 (maybe-truncate ny g2))
-		      (* (maybe-truncate dx g2)
-			 (maybe-truncate dy g1))))))))
+              (dx (denominator x))
+              (ny (numerator y))
+              (dy (denominator y))
+              (g1 (gcd nx dy))
+              (g2 (gcd dx ny)))
+         (build-ratio (* (maybe-truncate nx g1)
+                         (maybe-truncate ny g2))
+                      (* (maybe-truncate dx g2)
+                         (maybe-truncate dy g1))))))))
 
 ;;; Divide two integers, producing a canonical rational. If a fixnum,
 ;;; we see whether they divide evenly before trying the GCD. In the
@@ -474,17 +510,17 @@
 (defun integer-/-integer (x y)
   (if (and (typep x 'fixnum) (typep y 'fixnum))
       (multiple-value-bind (quo rem) (truncate x y)
-	(if (zerop rem)
-	    quo
-	    (let ((gcd (gcd x y)))
-	      (declare (fixnum gcd))
-	      (if (eql gcd 1)
-		  (build-ratio x y)
-		  (build-ratio (truncate x gcd) (truncate y gcd))))))
+        (if (zerop rem)
+            quo
+            (let ((gcd (gcd x y)))
+              (declare (fixnum gcd))
+              (if (eql gcd 1)
+                  (build-ratio x y)
+                  (build-ratio (truncate x gcd) (truncate y gcd))))))
       (let ((gcd (gcd x y)))
-	(if (eql gcd 1)
-	    (build-ratio x y)
-	    (build-ratio (truncate x gcd) (truncate y gcd))))))
+        (if (eql gcd 1)
+            (build-ratio x y)
+            (build-ratio (truncate x gcd) (truncate y gcd))))))
 
 (defun two-arg-/ (x y)
   (number-dispatch ((x number) (y number))
@@ -492,61 +528,61 @@
 
     ((complex complex)
      (let* ((rx (realpart x))
-	    (ix (imagpart x))
-	    (ry (realpart y))
-	    (iy (imagpart y)))
+            (ix (imagpart x))
+            (ry (realpart y))
+            (iy (imagpart y)))
        (if (> (abs ry) (abs iy))
-	   (let* ((r (/ iy ry))
-		  (dn (* ry (+ 1 (* r r)))))
-	     (canonical-complex (/ (+ rx (* ix r)) dn)
-				(/ (- ix (* rx r)) dn)))
-	   (let* ((r (/ ry iy))
-		  (dn (* iy (+ 1 (* r r)))))
-	     (canonical-complex (/ (+ (* rx r) ix) dn)
-				(/ (- (* ix r) rx) dn))))))
+           (let* ((r (/ iy ry))
+                  (dn (* ry (+ 1 (* r r)))))
+             (canonical-complex (/ (+ rx (* ix r)) dn)
+                                (/ (- ix (* rx r)) dn)))
+           (let* ((r (/ ry iy))
+                  (dn (* iy (+ 1 (* r r)))))
+             (canonical-complex (/ (+ (* rx r) ix) dn)
+                                (/ (- (* ix r) rx) dn))))))
     (((foreach integer ratio single-float double-float) complex)
      (let* ((ry (realpart y))
-	    (iy (imagpart y)))
+            (iy (imagpart y)))
        (if (> (abs ry) (abs iy))
-	   (let* ((r (/ iy ry))
-		  (dn (* ry (+ 1 (* r r)))))
-	     (canonical-complex (/ x dn)
-				(/ (- (* x r)) dn)))
-	   (let* ((r (/ ry iy))
-		  (dn (* iy (+ 1 (* r r)))))
-	     (canonical-complex (/ (* x r) dn)
-				(/ (- x) dn))))))
+           (let* ((r (/ iy ry))
+                  (dn (* ry (+ 1 (* r r)))))
+             (canonical-complex (/ x dn)
+                                (/ (- (* x r)) dn)))
+           (let* ((r (/ ry iy))
+                  (dn (* iy (+ 1 (* r r)))))
+             (canonical-complex (/ (* x r) dn)
+                                (/ (- x) dn))))))
     ((complex (or rational float))
      (canonical-complex (/ (realpart x) y)
-			(/ (imagpart x) y)))
+                        (/ (imagpart x) y)))
 
     ((ratio ratio)
      (let* ((nx (numerator x))
-	    (dx (denominator x))
-	    (ny (numerator y))
-	    (dy (denominator y))
-	    (g1 (gcd nx ny))
-	    (g2 (gcd dx dy)))
+            (dx (denominator x))
+            (ny (numerator y))
+            (dy (denominator y))
+            (g1 (gcd nx ny))
+            (g2 (gcd dx dy)))
        (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2))
-		    (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
+                    (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
 
     ((integer integer)
      (integer-/-integer x y))
 
     ((integer ratio)
      (if (zerop x)
-	 0
-	 (let* ((ny (numerator y))
-		(dy (denominator y))
-		(gcd (gcd x ny)))
-	   (build-ratio (* (maybe-truncate x gcd) dy)
-			(maybe-truncate ny gcd)))))
+         0
+         (let* ((ny (numerator y))
+                (dy (denominator y))
+                (gcd (gcd x ny)))
+           (build-ratio (* (maybe-truncate x gcd) dy)
+                        (maybe-truncate ny gcd)))))
 
     ((ratio integer)
      (let* ((nx (numerator x))
-	    (gcd (gcd nx y)))
+            (gcd (gcd nx y)))
        (build-ratio (maybe-truncate nx gcd)
-		    (* (maybe-truncate y gcd) (denominator x)))))))
+                    (* (maybe-truncate y gcd) (denominator x)))))))
 
 (defun %negate (n)
   (number-dispatch ((n number))
@@ -566,34 +602,34 @@
   "Return number (or number/divisor) as an integer, rounded toward 0.
   The second returned value is the remainder."
   (macrolet ((truncate-float (rtype)
-	       `(let* ((float-div (coerce divisor ',rtype))
-		       (res (%unary-truncate (/ number float-div))))
-		  (values res
-			  (- number
-			     (* (coerce res ',rtype) float-div))))))
+               `(let* ((float-div (coerce divisor ',rtype))
+                       (res (%unary-truncate (/ number float-div))))
+                  (values res
+                          (- number
+                             (* (coerce res ',rtype) float-div))))))
     (number-dispatch ((number real) (divisor real))
       ((fixnum fixnum) (truncate number divisor))
       (((foreach fixnum bignum) ratio)
        (let ((q (truncate (* number (denominator divisor))
-			  (numerator divisor))))
-	 (values q (- number (* q divisor)))))
+                          (numerator divisor))))
+         (values q (- number (* q divisor)))))
       ((fixnum bignum)
        (bignum-truncate (make-small-bignum number) divisor))
       ((ratio (or float rational))
        (let ((q (truncate (numerator number)
-			  (* (denominator number) divisor))))
-	 (values q (- number (* q divisor)))))
+                          (* (denominator number) divisor))))
+         (values q (- number (* q divisor)))))
       ((bignum fixnum)
        (bignum-truncate number (make-small-bignum divisor)))
       ((bignum bignum)
        (bignum-truncate number divisor))
 
       (((foreach single-float double-float #!+long-float long-float)
-	(or rational single-float))
+        (or rational single-float))
        (if (eql divisor 1)
-	   (let ((res (%unary-truncate number)))
-	     (values res (- number (coerce res '(dispatch-type number)))))
-	   (truncate-float (dispatch-type number))))
+           (let ((res (%unary-truncate number)))
+             (values res (- number (coerce res '(dispatch-type number)))))
+           (truncate-float (dispatch-type number))))
       #!+long-float
       ((long-float (or single-float double-float long-float))
        (truncate-float long-float))
@@ -605,47 +641,63 @@
       ((single-float double-float)
        (truncate-float double-float))
       (((foreach fixnum bignum ratio)
-	(foreach single-float double-float #!+long-float long-float))
+        (foreach single-float double-float #!+long-float long-float))
        (truncate-float (dispatch-type divisor))))))
 
+;; Only inline when no VOP exists
+#!-multiply-high-vops (declaim (inline %multiply-high))
+(defun %multiply-high (x y)
+  (declare (type word x y))
+  #!-multiply-high-vops
+  (values (sb!bignum:%multiply x y))
+  #!+multiply-high-vops
+  (%multiply-high x y))
+
 ;;; Declare these guys inline to let them get optimized a little.
 ;;; ROUND and FROUND are not declared inline since they seem too
 ;;; obscure and too big to inline-expand by default. Also, this gives
-;;; the compiler a chance to pick off the unary float case. Similarly,
-;;; CEILING and FLOOR are only maybe-inline for now, so that the
-;;; power-of-2 CEILING and FLOOR transforms get a chance.
-#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate))
-(declaim (maybe-inline ceiling floor))
+;;; the compiler a chance to pick off the unary float case.
+;;;
+;;; CEILING and FLOOR are implemented in terms of %CEILING and %FLOOR
+;;; if no better transform can be found: they aren't inline directly,
+;;; since we want to try a transform specific to them before letting
+;;; the transform for TRUNCATE pick up the slack.
+#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate %floor %ceiling))
+(defun %floor (number divisor)
+  ;; If the numbers do not divide exactly and the result of
+  ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
+  ;; and augment the remainder by the divisor.
+  (multiple-value-bind (tru rem) (truncate number divisor)
+    (if (and (not (zerop rem))
+             (if (minusp divisor)
+                 (plusp number)
+                 (minusp number)))
+        (values (1- tru) (+ rem divisor))
+        (values tru rem))))
 
 (defun floor (number &optional (divisor 1))
   #!+sb-doc
   "Return the greatest integer not greater than number, or number/divisor.
   The second returned value is (mod number divisor)."
+  (%floor number divisor))
+
+(defun %ceiling (number divisor)
   ;; If the numbers do not divide exactly and the result of
-  ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
-  ;; and augment the remainder by the divisor.
+  ;; (/ NUMBER DIVISOR) would be positive then increment the quotient
+  ;; and decrement the remainder by the divisor.
   (multiple-value-bind (tru rem) (truncate number divisor)
     (if (and (not (zerop rem))
-	     (if (minusp divisor)
-		 (plusp number)
-		 (minusp number)))
-	(values (1- tru) (+ rem divisor))
-	(values tru rem))))
+             (if (minusp divisor)
+                 (minusp number)
+                 (plusp number)))
+        (values (+ tru 1) (- rem divisor))
+        (values tru rem))))
 
 (defun ceiling (number &optional (divisor 1))
   #!+sb-doc
   "Return the smallest integer not less than number, or number/divisor.
   The second returned value is the remainder."
-  ;; If the numbers do not divide exactly and the result of
-  ;; (/ NUMBER DIVISOR) would be positive then increment the quotient
-  ;; and decrement the remainder by the divisor.
-  (multiple-value-bind (tru rem) (truncate number divisor)
-    (if (and (not (zerop rem))
-	     (if (minusp divisor)
-		 (minusp number)
-		 (plusp number)))
-	(values (+ tru 1) (- rem divisor))
-	(values tru rem))))
+  (%ceiling number divisor))
 
 (defun round (number &optional (divisor 1))
   #!+sb-doc
@@ -654,21 +706,21 @@
   (if (eql divisor 1)
       (round number)
       (multiple-value-bind (tru rem) (truncate number divisor)
-	(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))))))))
+        (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
@@ -682,11 +734,11 @@
   "Return second result of FLOOR."
   (let ((rem (rem number divisor)))
     (if (and (not (zerop rem))
-	     (if (minusp divisor)
-		 (plusp number)
-		 (minusp number)))
-	(+ rem divisor)
-	rem)))
+             (if (minusp divisor)
+                 (plusp number)
+                 (minusp number)))
+        (+ rem divisor)
+        rem)))
 
 (defmacro !define-float-rounding-function (name op doc)
   `(defun ,name (number &optional (divisor 1))
@@ -694,93 +746,130 @@
     (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.")
+(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."
-  (do ((nlist more-numbers (cdr nlist)))
-      ((atom nlist) T)
-     (declare (list nlist))
-     (if (not (= (car nlist) number)) (return nil))))
+  (declare (number number))
+  (dotimes (i (length more-numbers) t)
+    (unless (= number (nth i more-numbers))
+      (return nil))))
 
 (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))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (unless (do* ((nl nlist (cdr nl)))
-		  ((atom nl) T)
-	       (declare (list nl))
-	       (if (= head (car nl)) (return nil)))
-       (return nil))))
-
-(defun < (number &rest more-numbers)
-  #!+sb-doc
-  "Return T if its arguments are in strictly increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (< n (car nlist))) (return nil))))
-
-(defun > (number &rest more-numbers)
-  #!+sb-doc
-  "Return T if its arguments are in strictly decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (> n (car nlist))) (return nil))))
-
-(defun <= (number &rest more-numbers)
-  #!+sb-doc
-  "Return T if arguments are in strictly non-decreasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (<= n (car nlist))) (return nil))))
-
-(defun >= (number &rest more-numbers)
-  #!+sb-doc
-  "Return T if arguments are in strictly non-increasing order, NIL otherwise."
-  (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (>= n (car nlist))) (return nil))))
+  (declare (number number))
+  (if more-numbers
+      (do ((n number (nth i more-numbers))
+            (i 0 (1+ i)))
+          ((>= i (length more-numbers))
+           t)
+        (do ((j i (1+ j)))
+            ((>= j (length more-numbers)))
+          (when (= n (nth j more-numbers))
+            (return-from /= nil))))
+      t))
+
+(macrolet ((def (op doc)
+             #!-sb-doc (declare (ignore doc))
+             `(defun ,op (number &rest more-numbers)
+                #!+sb-doc ,doc
+                (let ((n number))
+                  (declare (number n))
+                  (dotimes (i (length more-numbers) t)
+                    (let ((arg (nth i more-numbers)))
+                      (if (,op n arg)
+                        (setf n arg)
+                        (return-from ,op nil))))))))
+  (def <  "Return T if its arguments are in strictly increasing order, NIL otherwise.")
+  (def >  "Return T if its arguments are in strictly decreasing order, NIL otherwise.")
+  (def <= "Return T if arguments are in strictly non-decreasing order, NIL otherwise.")
+  (def >= "Return T if arguments are in strictly non-increasing order, NIL otherwise."))
 
 (defun max (number &rest more-numbers)
   #!+sb-doc
-  "Return the greatest of its arguments."
-  (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)))))
+  "Return the greatest of its arguments; among EQUALP greatest, return
+the first."
+  (let ((n number))
+    (declare (number n))
+    (dotimes (i (length more-numbers) n)
+      (let ((arg (nth i more-numbers)))
+        (when (> arg n)
+          (setf n arg))))))
 
 (defun min (number &rest more-numbers)
   #!+sb-doc
-  "Return the least of its arguments."
-  (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)))))
+  "Return the least of its arguments; among EQUALP least, return
+the first."
+  (let ((n number))
+    (declare (number n))
+    (dotimes (i (length more-numbers) n)
+      (let ((arg (nth i more-numbers)))
+        (when (< arg n)
+          (setf n arg))))))
 
 (eval-when (:compile-toplevel :execute)
 
@@ -801,44 +890,78 @@
     #!+long-float
     ((long-float (foreach single-float double-float))
      (,op x (coerce y 'long-float)))
+    ((fixnum (foreach single-float double-float))
+     (if (float-infinity-p y)
+         ,infinite-y-finite-x
+         ;; If the fixnum has an exact float representation, do a
+         ;; float comparison. Otherwise do the slow float -> ratio
+         ;; conversion.
+         (multiple-value-bind (lo hi)
+             (case '(dispatch-type y)
+               (single-float
+                (values most-negative-exactly-single-float-fixnum
+                        most-positive-exactly-single-float-fixnum))
+               (double-float
+                (values most-negative-exactly-double-float-fixnum
+                        most-positive-exactly-double-float-fixnum)))
+           (if (<= lo y hi)
+               (,op (coerce x '(dispatch-type y)) y)
+               (,op x (rational y))))))
+    (((foreach single-float double-float) fixnum)
+     (if (eql y 0)
+         (,op x (coerce 0 '(dispatch-type x)))
+         (if (float-infinity-p x)
+             ,infinite-x-finite-y
+             ;; Likewise
+             (multiple-value-bind (lo hi)
+                 (case '(dispatch-type x)
+                   (single-float
+                    (values most-negative-exactly-single-float-fixnum
+                            most-positive-exactly-single-float-fixnum))
+                   (double-float
+                    (values most-negative-exactly-double-float-fixnum
+                            most-positive-exactly-double-float-fixnum)))
+               (if (<= lo y hi)
+                   (,op x (coerce y '(dispatch-type x)))
+                   (,op (rational x) y))))))
     (((foreach single-float double-float) double-float)
      (,op (coerce x 'double-float) y))
     ((double-float single-float)
      (,op x (coerce y 'double-float)))
     (((foreach single-float double-float #!+long-float long-float) rational)
      (if (eql y 0)
-	 (,op x (coerce 0 '(dispatch-type x)))
-	 (if (float-infinity-p x)
-	     ,infinite-x-finite-y
-	     (,op (rational x) y))))
+         (,op x (coerce 0 '(dispatch-type x)))
+         (if (float-infinity-p x)
+             ,infinite-x-finite-y
+             (,op (rational x) y))))
     (((foreach bignum fixnum ratio) float)
      (if (float-infinity-p y)
-	 ,infinite-y-finite-x
-	 (,op x (rational y))))))
+         ,infinite-y-finite-x
+         (,op x (rational y))))))
 ) ; EVAL-WHEN
 
 (macrolet ((def-two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
              `(defun ,name (x y)
-		(number-dispatch ((x real) (y real))
-				 (basic-compare
-				  ,op
-				  :infinite-x-finite-y
-				  (,op x (coerce 0 '(dispatch-type x)))
-				  :infinite-y-finite-x
-				  (,op (coerce 0 '(dispatch-type y)) y))
-				 (((foreach fixnum bignum) ratio)
-				  (,op x (,ratio-arg2 (numerator y)
-						      (denominator y))))
-				 ((ratio integer)
-				  (,op (,ratio-arg1 (numerator x)
-						    (denominator x))
-				       y))
-				 ((ratio ratio)
-				  (,op (* (numerator   (truly-the ratio x))
-					  (denominator (truly-the ratio y)))
-				       (* (numerator   (truly-the ratio y))
-					  (denominator (truly-the ratio x)))))
-				 ,@cases))))
+                (number-dispatch ((x real) (y real))
+                                 (basic-compare
+                                  ,op
+                                  :infinite-x-finite-y
+                                  (,op x (coerce 0 '(dispatch-type x)))
+                                  :infinite-y-finite-x
+                                  (,op (coerce 0 '(dispatch-type y)) y))
+                                 (((foreach fixnum bignum) ratio)
+                                  (,op x (,ratio-arg2 (numerator y)
+                                                      (denominator y))))
+                                 ((ratio integer)
+                                  (,op (,ratio-arg1 (numerator x)
+                                                    (denominator x))
+                                       y))
+                                 ((ratio ratio)
+                                  (,op (* (numerator   (truly-the ratio x))
+                                          (denominator (truly-the ratio y)))
+                                       (* (numerator   (truly-the ratio y))
+                                          (denominator (truly-the ratio x)))))
+                                 ,@cases))))
   (def-two-arg-</> two-arg-< < floor ceiling
     ((fixnum bignum)
      (bignum-plus-p y))
@@ -857,9 +980,9 @@
 (defun two-arg-= (x y)
   (number-dispatch ((x number) (y number))
     (basic-compare =
-		   ;; An infinite value is never equal to a finite value.
-		   :infinite-x-finite-y nil
-		   :infinite-y-finite-x nil)
+                   ;; An infinite value is never equal to a finite value.
+                   :infinite-x-finite-y nil
+                   :infinite-y-finite-x nil)
     ((fixnum (or bignum ratio)) nil)
 
     ((bignum (or fixnum ratio)) nil)
@@ -869,93 +992,36 @@
     ((ratio integer) nil)
     ((ratio ratio)
      (and (eql (numerator x) (numerator y))
-	  (eql (denominator x) (denominator y))))
+          (eql (denominator x) (denominator y))))
 
     ((complex complex)
      (and (= (realpart x) (realpart y))
-	  (= (imagpart x) (imagpart y))))
+          (= (imagpart x) (imagpart y))))
     (((foreach fixnum bignum ratio single-float double-float
-	       #!+long-float long-float) complex)
+               #!+long-float long-float) complex)
      (and (= x (realpart y))
-	  (zerop (imagpart y))))
+          (zerop (imagpart y))))
     ((complex (or float rational))
      (and (= (realpart x) y)
-	  (zerop (imagpart x))))))
-
-(defun eql (obj1 obj2)
-  #!+sb-doc
-  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
-  (or (eq obj1 obj2)
-      (if (or (typep obj2 'fixnum)
-	      (not (typep obj2 'number)))
-	  nil
-	  (macrolet ((foo (&rest stuff)
-		       `(typecase obj2
-			  ,@(mapcar (lambda (foo)
-				      (let ((type (car foo))
-					    (fn (cadr foo)))
-					`(,type
-					  (and (typep obj1 ',type)
-					       (,fn obj1 obj2)))))
-				    stuff))))
-	    (foo
-	      (single-float eql)
-	      (double-float eql)
-	      #!+long-float
-	      (long-float eql)
-	      (bignum
-	       (lambda (x y)
-		 (zerop (bignum-compare x y))))
-	      (ratio
-	       (lambda (x y)
-		 (and (eql (numerator x) (numerator y))
-		      (eql (denominator x) (denominator y)))))
-	      (complex
-	       (lambda (x y)
-		 (and (eql (realpart x) (realpart y))
-		      (eql (imagpart x) (imagpart y))))))))))
+          (zerop (imagpart x))))))
 
 ;;;; logicals
 
-(defun logior (&rest integers)
-  #!+sb-doc
-  "Return the bit-wise or of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logior result (pop integers))))
-	  ((null integers) result)
-	(declare (integer result)))
-      0))
-
-(defun logxor (&rest integers)
-  #!+sb-doc
-  "Return the bit-wise exclusive or of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logxor result (pop integers))))
-	  ((null integers) result)
-	(declare (integer result)))
-      0))
-
-(defun logand (&rest integers)
-  #!+sb-doc
-  "Return the bit-wise and of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logand result (pop integers))))
-	  ((null integers) result)
-	(declare (integer result)))
-      -1))
-
-(defun logeqv (&rest integers)
-  #!+sb-doc
-  "Return the bit-wise equivalence of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logeqv result (pop integers))))
-	  ((null integers) result)
-	(declare (integer result)))
-      -1))
+(macrolet ((def (op init doc)
+             #!-sb-doc (declare (ignore doc))
+             `(defun ,op (&rest integers)
+                #!+sb-doc ,doc
+                (if integers
+                    (do ((result (nth 0 integers) (,op result (nth i integers)))
+                         (i 1 (1+ i)))
+                        ((>= i (length integers))
+                         result)
+                      (declare (integer result)))
+                    ,init))))
+  (def logior 0 "Return the bit-wise or of its arguments. Args must be integers.")
+  (def logxor 0 "Return the bit-wise exclusive or of its arguments. Args must be integers.")
+  (def logand -1 "Return the bit-wise and of its arguments. Args must be integers.")
+  (def logeqv -1 "Return the bit-wise equivalence of its arguments. Args must be integers."))
 
 (defun lognot (number)
   #!+sb-doc
@@ -965,21 +1031,21 @@
     (bignum (bignum-logical-not number))))
 
 (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))))))
+             `(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)
   ;; 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))) 
+  (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)))
@@ -1004,11 +1070,12 @@
   if INTEGER is negative."
   (etypecase integer
     (fixnum
-     (logcount (truly-the (integer 0 #.(max most-positive-fixnum
-					    (lognot most-negative-fixnum)))
-			  (if (minusp (truly-the fixnum integer))
-			      (lognot (truly-the fixnum integer))
-			      integer))))
+     (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))))
     (bignum
      (bignum-logcount integer))))
 
@@ -1020,7 +1087,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-positive-fixnum-bits)
+                         (not (zerop (logand integer (ash 1 index))))
+                         (minusp integer)))
+    ((fixnum bignum) (bignum-logbitp index integer))
+    ((bignum (foreach fixnum bignum)) (minusp integer))))
 
 (defun ash (integer count)
   #!+sb-doc
@@ -1029,30 +1101,31 @@
   (etypecase integer
     (fixnum
      (cond ((zerop integer)
-	    0)
-	   ((fixnump count)
-	    (let ((length (integer-length (truly-the fixnum integer)))
-		  (count (truly-the fixnum count)))
-	      (declare (fixnum length count))
-	      (cond ((and (plusp count)
-			  (> (+ length count)
-			     (integer-length most-positive-fixnum)))
-		     (bignum-ashift-left (make-small-bignum integer) count))
-		    (t
-		     (truly-the fixnum
-				(ash (truly-the fixnum integer) count))))))
-	   ((minusp count)
-	    (if (minusp integer) -1 0))
-	   (t
-	    (bignum-ashift-left (make-small-bignum integer) count))))
+            0)
+           ((fixnump count)
+            (let ((length (integer-length (truly-the fixnum integer)))
+                  (count (truly-the fixnum count)))
+              (declare (fixnum length count))
+              (cond ((and (plusp count)
+                          (> (+ length count)
+                             (integer-length most-positive-fixnum)))
+                     (bignum-ashift-left (make-small-bignum integer) count))
+                    (t
+                     (truly-the fixnum
+                                (ash (truly-the fixnum integer) count))))))
+           ((minusp count)
+            (if (minusp integer) -1 0))
+           (t
+            (bignum-ashift-left (make-small-bignum integer) count))))
     (bignum
      (if (plusp count)
-	 (bignum-ashift-left integer count)
-	 (bignum-ashift-right integer (- count))))))
+         (bignum-ashift-left integer count)
+         (bignum-ashift-right integer (- count))))))
 
 (defun integer-length (integer)
   #!+sb-doc
-  "Return the number of significant bits in the absolute value of integer."
+  "Return the number of non-sign bits in the twos-complement representation
+  of INTEGER."
   (etypecase integer
     (fixnum
      (integer-length (truly-the fixnum integer)))
@@ -1103,21 +1176,37 @@
   (deposit-field newbyte bytespec integer))
 
 (defun %ldb (size posn integer)
+  (declare (type bit-index size posn))
   (logand (ash integer (- posn))
-	  (1- (ash 1 size))))
+          (1- (ash 1 size))))
 
 (defun %mask-field (size posn integer)
+  (declare (type bit-index size posn))
   (logand integer (ash (1- (ash 1 size)) posn)))
 
 (defun %dpb (newbyte size posn integer)
+  (declare (type bit-index size posn))
   (let ((mask (1- (ash 1 size))))
     (logior (logand integer (lognot (ash mask posn)))
-	    (ash (logand newbyte mask) posn))))
+            (ash (logand newbyte mask) posn))))
 
 (defun %deposit-field (newbyte size posn integer)
+  (declare (type bit-index size posn))
   (let ((mask (ash (ldb (byte size 0) -1) posn)))
     (logior (logand newbyte mask)
-	    (logand integer (lognot mask)))))
+            (logand integer (lognot mask)))))
+
+(defun sb!c::mask-signed-field (size integer)
+  #!+sb-doc
+  "Extract SIZE lower bits from INTEGER, considering them as a
+2-complement SIZE-bits representation of a signed integer."
+  (cond ((zerop size)
+         0)
+        ((logbitp (1- size) integer)
+         (dpb integer (byte size 0) -1))
+        (t
+         (ldb (byte size 0) integer))))
+
 
 ;;;; BOOLE
 
@@ -1193,22 +1282,22 @@
 (defun boole (op integer1 integer2)
   #!+sb-doc
   "Bit-wise boolean function on two integers. Function chosen by OP:
-	0	BOOLE-CLR
-	1	BOOLE-SET
-	2	BOOLE-1
-  	3	BOOLE-2
-	4	BOOLE-C1
-	5	BOOLE-C2
-	6	BOOLE-AND
-	7	BOOLE-IOR
- 	8	BOOLE-XOR
-	9	BOOLE-EQV
-	10	BOOLE-NAND
-	11	BOOLE-NOR
-	12	BOOLE-ANDC1
-	13	BOOLE-ANDC2
-	14	BOOLE-ORC1
-	15	BOOLE-ORC2"
+        0       BOOLE-CLR
+        1       BOOLE-SET
+        2       BOOLE-1
+        3       BOOLE-2
+        4       BOOLE-C1
+        5       BOOLE-C2
+        6       BOOLE-AND
+        7       BOOLE-IOR
+        8       BOOLE-XOR
+        9       BOOLE-EQV
+        10      BOOLE-NAND
+        11      BOOLE-NOR
+        12      BOOLE-ANDC1
+        13      BOOLE-ANDC2
+        14      BOOLE-ORC1
+        15      BOOLE-ORC2"
   (case op
     (0 (boole 0 integer1 integer2))
     (1 (boole 1 integer1 integer2))
@@ -1230,42 +1319,56 @@
 
 ;;;; GCD and LCM
 
-(defun gcd (&rest numbers)
+(defun gcd (&rest integers)
   #!+sb-doc
   "Return the greatest common divisor of the arguments, which must be
-  integers. Gcd with no arguments is defined to be 0."
-  (cond ((null numbers) 0)
-	((null (cdr numbers)) (abs (the integer (car numbers))))
-	(t
-	 (do ((gcd (the integer (car numbers))
-		   (gcd gcd (the integer (car rest))))
-	      (rest (cdr numbers) (cdr rest)))
-	     ((null rest) gcd)
-	   (declare (integer gcd)
-		    (list rest))))))
-
-(defun lcm (&rest numbers)
+  integers. GCD with no arguments is defined to be 0."
+  (case (length integers)
+    (0 0)
+    (1 (abs (the integer (nth 0 integers))))
+    (otherwise
+     (do ((result (nth 0 integers)
+                  (gcd result (the integer (nth i integers))))
+          (i 1 (1+ i)))
+         ((>= i (length integers))
+          result)
+       (declare (integer result))))))
+
+(defun lcm (&rest integers)
   #!+sb-doc
   "Return the least common multiple of one or more integers. LCM of no
   arguments is defined to be 1."
-  (cond ((null numbers) 1)
-	((null (cdr numbers)) (abs (the integer (car numbers))))
-	(t
-	 (do ((lcm (the integer (car numbers))
-		   (lcm lcm (the integer (car rest))))
-	      (rest (cdr numbers) (cdr rest)))
-	     ((null rest) lcm)
-	   (declare (integer lcm) (list rest))))))
+  (case (length integers)
+    (0 1)
+    (1 (abs (the integer (nth 0 integers))))
+    (otherwise
+     (do ((result (nth 0 integers)
+                  (lcm result (the integer (nth i integers))))
+          (i 1 (1+ i)))
+         ((>= i (length integers))
+          result)
+       (declare (integer result))))))
 
 (defun two-arg-lcm (n m)
   (declare (integer n m))
-  (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))))
+  (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
+      ;;
+      ;;    It seems to me that this is written this way to avoid
+      ;;    unnecessary bignumification of intermediate results.
+      ;;        -- TCR, 2008-03-05
+      (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
@@ -1274,67 +1377,104 @@
 ;;; about "small bignum" zeros.
 (defun two-arg-gcd (u v)
   (cond ((eql u 0) (abs v))
-	((eql v 0) (abs u))
-	(t
-	 (number-dispatch ((u integer) (v integer))
-	   ((fixnum fixnum)
-	    (locally
-	      (declare (optimize (speed 3) (safety 0)))
-	      (do ((k 0 (1+ k))
-		   (u (abs u) (ash u -1))
-		   (v (abs v) (ash v -1)))
-		  ((oddp (logior u v))
-		   (do ((temp (if (oddp u) (- v) (ash u -1))
-			      (ash temp -1)))
-		       (nil)
-		     (declare (fixnum temp))
-		     (when (oddp temp)
-		       (if (plusp temp)
-			   (setq u temp)
-			   (setq v (- temp)))
-		       (setq temp (- u v))
-		       (when (zerop temp)
-			 (let ((res (ash u k)))
-			   (declare (type (signed-byte 31) res)
-				    (optimize (inhibit-warnings 3)))
-			   (return res))))))
-		(declare (type (mod 30) k)
-			 (type (signed-byte 31) u v)))))
-	   ((bignum bignum)
-	    (bignum-gcd u v))
-	   ((bignum fixnum)
-	    (bignum-gcd u (make-small-bignum v)))
-	   ((fixnum bignum)
-	    (bignum-gcd (make-small-bignum u) v))))))
+        ((eql v 0) (abs u))
+        (t
+         (number-dispatch ((u integer) (v integer))
+           ((fixnum fixnum)
+            (locally
+                (declare (optimize (speed 3) (safety 0)))
+              (do ((k 0 (1+ k))
+                   (u (abs u) (ash u -1))
+                   (v (abs v) (ash v -1)))
+                  ((oddp (logior u v))
+                   (do ((temp (if (oddp u) (- v) (ash u -1))
+                              (ash temp -1)))
+                       (nil)
+                     (declare (fixnum temp))
+                     (when (oddp temp)
+                       (if (plusp temp)
+                           (setq u temp)
+                           (setq v (- temp)))
+                       (setq temp (- u v))
+                       (when (zerop temp)
+                         (let ((res (ash u k)))
+                           (declare (type sb!vm:signed-word res)
+                                    (optimize (inhibit-warnings 3)))
+                           (return res))))))
+                (declare (type (mod #.sb!vm:n-word-bits) k)
+                         (type sb!vm:signed-word u v)))))
+           ((bignum bignum)
+            (bignum-gcd u v))
+           ((bignum fixnum)
+            (bignum-gcd u (make-small-bignum v)))
+           ((fixnum bignum)
+            (bignum-gcd (make-small-bignum u) v))))))
 
-;;; From discussion on comp.lang.lisp and Akira Kurihara.
+;;; from Robert Smith; changed not to cons unnecessarily, and tuned for
+;;; faster operation on fixnum inputs by compiling the central recursive
+;;; algorithm twice, once using generic and once fixnum arithmetic, and
+;;; dispatching on function entry into the applicable part. For maximum
+;;; speed, the fixnum part recurs into itself, thereby avoiding further
+;;; type dispatching. This pattern is not supported by NUMBER-DISPATCH
+;;; thus some special-purpose macrology is needed.
 (defun isqrt (n)
   #!+sb-doc
-  "Return the root of the nearest integer less than n which is a perfect
-   square."
-  (declare (type unsigned-byte n) (values unsigned-byte))
-  ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
-  (if (and (fixnump n) (<= n 24))
-      (cond ((> n 15) 4)
-	    ((> n  8) 3)
-	    ((> n  3) 2)
-	    ((> n  0) 1)
-	    (t 0))
-      (let* ((n-len-quarter (ash (integer-length n) -2))
-	     (n-half (ash n (- (ash n-len-quarter 1))))
-	     (n-half-isqrt (isqrt n-half))
-	     (init-value (ash (1+ n-half-isqrt) n-len-quarter)))
-	(loop
-	  (let ((iterated-value
-		 (ash (+ init-value (truncate n init-value)) -1)))
-	    (unless (< iterated-value init-value)
-	      (return init-value))
-	    (setq init-value iterated-value))))))
+  "Return the greatest integer less than or equal to the square root of N."
+  (declare (type unsigned-byte n))
+  (macrolet
+      ((isqrt-recursion (arg recurse fixnum-p)
+         ;; Expands into code for the recursive step of the ISQRT
+         ;; calculation. ARG is the input variable and RECURSE the name
+         ;; of the function to recur into. If FIXNUM-P is true, some
+         ;; type declarations are added that, together with ARG being
+         ;; declared as a fixnum outside of here, make the resulting code
+         ;; compile into fixnum-specialized code without any calls to
+         ;; generic arithmetic. Else, the code works for bignums, too.
+         ;; The input must be at least 16 to ensure that RECURSE is called
+         ;; with a strictly smaller number and that the result is correct
+         ;; (provided that RECURSE correctly implements ISQRT, itself).
+         `(macrolet ((if-fixnum-p-truly-the (type expr)
+                       ,@(if fixnum-p
+                             '(`(truly-the ,type ,expr))
+                             '((declare (ignore type))
+                               expr))))
+            (let* ((fourth-size (ash (1- (integer-length ,arg)) -2))
+                   (significant-half (ash ,arg (- (ash fourth-size 1))))
+                   (significant-half-isqrt
+                    (if-fixnum-p-truly-the
+                     (integer 1 #.(isqrt sb!xc:most-positive-fixnum))
+                     (,recurse significant-half)))
+                   (zeroth-iteration (ash significant-half-isqrt
+                                          fourth-size)))
+              (multiple-value-bind (quot rem)
+                  (floor ,arg zeroth-iteration)
+                (let ((first-iteration (ash (+ zeroth-iteration quot) -1)))
+                  (cond ((oddp quot)
+                         first-iteration)
+                        ((> (if-fixnum-p-truly-the
+                             fixnum
+                             (expt (- first-iteration zeroth-iteration) 2))
+                            rem)
+                         (1- first-iteration))
+                        (t
+                         first-iteration))))))))
+    (typecase n
+      (fixnum (labels ((fixnum-isqrt (n)
+                         (declare (type fixnum n))
+                         (cond ((> n 24)
+                                (isqrt-recursion n fixnum-isqrt t))
+                               ((> n 15) 4)
+                               ((> n  8) 3)
+                               ((> n  3) 2)
+                               ((> n  0) 1)
+                               ((= n  0) 0))))
+                (fixnum-isqrt n)))
+      (bignum (isqrt-recursion n isqrt nil)))))
 
 ;;;; miscellaneous number predicates
 
 (macrolet ((def (name doc)
-	     `(defun ,name (number) ,doc (,name number))))
+             `(defun ,name (number) ,doc (,name number))))
   (def zerop "Is this number zero?")
   (def plusp "Is this real number strictly positive?")
   (def minusp "Is this real number strictly negative?")
@@ -1344,26 +1484,66 @@
 ;;;; modular functions
 #.
 (collect ((forms))
-  (flet ((definition (name lambda-list width pattern)
-           ;; We rely on (SUBTYPEP `(UNSIGNED-BYTE ,WIDTH)
-           ;;                      'BIGNUM-ELEMENT-TYPE)
+  (flet ((unsigned-definition (name lambda-list width)
+           (let ((pattern (1- (ash 1 width))))
+             `(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)))))))
+         (signed-definition (name lambda-list width)
            `(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)))))
+                         ((signed-byte ,width) x)
+                         (fixnum (sb!c::mask-signed-field ,width x))
+                         (bignum (sb!c::mask-signed-field ,width x)))))
                 (,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)))
+    (flet ((do-mfuns (class)
+             (loop for infos being each hash-value of (sb!c::modular-class-funs class)
+                   ;; 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 signedp = (sb!c::modular-fun-info-signedp info)
+                            and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+                            if signedp
+                            do (forms (signed-definition name lambda-list width))
+                            else
+                            do (forms (unsigned-definition name lambda-list width))))))
+      (do-mfuns sb!c::*untagged-unsigned-modular-class*)
+      (do-mfuns sb!c::*untagged-signed-modular-class*)
+      (do-mfuns sb!c::*tagged-modular-class*)))
+  `(progn ,@(sort (forms) #'string< :key #'cadr)))
+
+;;; 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
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 32) '(and) '(or))
+(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)))))
+#!+#.(cl:if (cl:= sb!vm:n-machine-word-bits 64) '(and) '(or))
+(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)))))
+
+#!+(or x86 x86-64)
+(defun sb!vm::ash-left-modfx (integer amount)
+  (let ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)))
+    (etypecase integer
+      (fixnum (sb!c::mask-signed-field fixnum-width (ash integer amount)))
+      (integer (sb!c::mask-signed-field fixnum-width (ash (sb!c::mask-signed-field fixnum-width integer) amount))))))