gencgc: More precise conservatism for pointers to boxed pages.

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

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index af798b0..40706af 100644 (file)
--- 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)
 ;;; 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.)
 
 ;;; 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*))
 ;;; 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)
     (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.
 
 ;;; 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))
 (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
       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.
 ;;; 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))
 (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))
     (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)
 
     (collect ((errors)

-             (error-tags))
+              (error-tags))

       (dolist (spec var-specs)
       (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
 
       `(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))))))

 \f
 ;;;; binary operation dispatching utilities
 
 \f
 ;;;; binary operation dispatching utilities
 

@@ -173,17 +221,17 @@
   (if (eql imagpart 0)
       realpart
       (cond #!+long-float
   (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,
 
 ;;; 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)
 (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
     (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)))))
 
       ((eql den 1) num)
       (t (%make-ratio num den)))))
 

@@ -215,21 +263,21 @@
   #!+sb-doc
   "Return a complex number with the specified real and imaginary components."
   (flet ((%%make-complex (realpart imagpart)
   #!+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))
   (number-dispatch ((realpart real) (imagpart real))
     ((rational rational)
      (canonical-complex realpart imagpart))

@@ -238,7 +286,7 @@
 (defun realpart (number)
   #!+sb-doc
   "Extract the real part of a number."
 (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)))
     #!+long-float
     ((complex long-float)
      (truly-the long-float (realpart number)))

@@ -248,13 +296,13 @@
      (truly-the single-float (realpart number)))
     ((complex rational)
      (sb!kernel:%realpart number))
      (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."
      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)))
     #!+long-float
     ((complex long-float)
      (truly-the long-float (imagpart number)))

@@ -266,13 +314,14 @@
      (sb!kernel:%imagpart number))
     (float
      (* 0 number))
      (sb!kernel:%imagpart number))
     (float
      (* 0 number))

-    (t
+    (number

      0)))
 
 (defun conjugate (number)
   #!+sb-doc
   "Return the complex conjugate of NUMBER. For non-complex numbers, this is
   an identity."
      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))
   (if (complexp number)
       (complex (realpart number) (- (imagpart number)))
       number))

@@ -283,8 +332,8 @@
   (if (zerop number)
       number
       (if (rationalp number)
   (if (zerop number)
       number
       (if (rationalp number)

-         (if (plusp number) 1 -1)
-         (/ number (abs number)))))
+          (if (plusp number) 1 -1)
+          (/ number (abs number)))))

 \f
 ;;;; ratios
 
 \f
 ;;;; ratios
 

@@ -299,17 +348,27 @@
   (denominator number))
 \f
 ;;;; arithmetic operations
   (denominator number))
 \f
 ;;;; 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)
 
 (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
   (define-arith + 0
     "Return the sum of its arguments. With no args, returns 0.")
   (define-arith * 1

@@ -317,14 +376,12 @@
 
 (defun - (number &rest more-numbers)
   #!+sb-doc
 
 (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
   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)
       (- number)))
 
 (defun / (number &rest more-numbers)

@@ -332,11 +389,9 @@
   "Divide the first argument by each of the following arguments, in turn.
   With one argument, return reciprocal."
   (if more-numbers
   "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)
       (/ number)))
 
 (defun 1+ (number)

@@ -358,40 +413,40 @@
        (float-contagion ,op x y)
 
        ((complex complex)
        (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
        (((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 (or rational float))

-       (complex (,op (realpart x) y) (imagpart x)))
+        (complex (,op (realpart x) y) (,op (imagpart x) 0)))

 
        (((foreach fixnum bignum) ratio)
 
        (((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)
        ((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)
        ((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
 
 
 ) ; EVAL-WHEN
 

@@ -400,19 +455,19 @@
 
 (defun two-arg-* (x y)
   (flet ((integer*ratio (x y)
 
 (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)
 
     (number-dispatch ((x number) (y number))
       (float-contagion * x y)
 

@@ -423,13 +478,13 @@
 
       ((complex complex)
        (let* ((rx (realpart x))
 
       ((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
       (((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))
        (complex*real y x))
       ((complex (or rational float))
        (complex*real x y))

@@ -438,15 +493,15 @@
       ((ratio integer) (integer*ratio y x))
       ((ratio ratio)
        (let* ((nx (numerator x))
       ((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
 
 ;;; Divide two integers, producing a canonical rational. If a fixnum,
 ;;; we see whether they divide evenly before trying the GCD. In the

@@ -455,17 +510,17 @@
 (defun integer-/-integer (x y)
   (if (and (typep x 'fixnum) (typep y 'fixnum))
       (multiple-value-bind (quo rem) (truncate x y)
 (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)))
       (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))
 
 (defun two-arg-/ (x y)
   (number-dispatch ((x number) (y number))

@@ -473,61 +528,61 @@
 
     ((complex complex)
      (let* ((rx (realpart x))
 
     ((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))
        (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))
     (((foreach integer ratio single-float double-float) complex)
      (let* ((ry (realpart y))

-           (iy (imagpart y)))
+            (iy (imagpart y)))

        (if (> (abs ry) (abs iy))
        (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)
     ((complex (or rational float))
      (canonical-complex (/ (realpart x) y)

-                       (/ (imagpart x) y)))
+                        (/ (imagpart x) y)))

 
     ((ratio ratio)
      (let* ((nx (numerator x))
 
     ((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))
        (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)
 
     ((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))
 
     ((ratio integer)
      (let* ((nx (numerator x))

-           (gcd (gcd nx y)))
+            (gcd (gcd nx y)))

        (build-ratio (maybe-truncate nx gcd)
        (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))
 
 (defun %negate (n)
   (number-dispatch ((n number))

@@ -547,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)
   "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))
     (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)
       ((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)
       ((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)
        (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))
       #!+long-float
       ((long-float (or single-float double-float long-float))
        (truncate-float long-float))

@@ -586,47 +641,63 @@
       ((single-float double-float)
        (truncate-float double-float))
       (((foreach fixnum bignum ratio)
       ((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))))))
 
        (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
 ;;; 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)."
 
 (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
   ;; 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))
   (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."
 
 (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
 
 (defun round (number &optional (divisor 1))
   #!+sb-doc

@@ -635,21 +706,21 @@
   (if (eql divisor 1)
       (round number)
       (multiple-value-bind (tru rem) (truncate number divisor)
   (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
 
 (defun rem (number divisor)
   #!+sb-doc

@@ -663,11 +734,11 @@
   "Return second result of FLOOR."
   (let ((rem (rem number divisor)))
     (if (and (not (zerop rem))
   "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))
 
 (defmacro !define-float-rounding-function (name op doc)
   `(defun ,name (number &optional (divisor 1))

@@ -679,22 +750,22 @@
   #!+sb-doc
   "Same as TRUNCATE, but returns first value as a float."
   (macrolet ((ftruncate-float (rtype)
   #!+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))))))
+               `(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)
     (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)))
+           (truncate number divisor)
+         (values (float q) r)))

       (((foreach single-float double-float #!+long-float long-float)
       (((foreach single-float double-float #!+long-float long-float)

-       (or rational single-float))
+        (or rational single-float))

        (if (eql divisor 1)
        (if (eql divisor 1)

-          (let ((res (%unary-ftruncate number)))
-            (values res (- number (coerce res '(dispatch-type number)))))
-          (ftruncate-float (dispatch-type number))))
+           (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
       ((long-float (or single-float double-float long-float))
        (ftruncate-float long-float))

@@ -706,7 +777,7 @@
       ((single-float double-float)
        (ftruncate-float double-float))
       (((foreach fixnum bignum ratio)
       ((single-float double-float)
        (ftruncate-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))

        (ftruncate-float (dispatch-type divisor))))))
 
 (defun ffloor (number &optional (divisor 1))
        (ftruncate-float (dispatch-type divisor))))))
 
 (defun ffloor (number &optional (divisor 1))

@@ -742,82 +813,63 @@
 (defun = (number &rest more-numbers)
   #!+sb-doc
   "Return T if all of its arguments are numerically equal, NIL otherwise."
 (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))
-     (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."
 
 (defun /= (number &rest more-numbers)
   #!+sb-doc
   "Return T if no two of its arguments are numerically equal, NIL otherwise."

-  (do* ((head (the number 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 (the number 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 (the number 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 (the number 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 (the number 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; among EQUALP greatest, return
 the first."
 
 (defun max (number &rest more-numbers)
   #!+sb-doc
   "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)))))
+  (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; among EQUALP least, return
 the first."
 
 (defun min (number &rest more-numbers)
   #!+sb-doc
   "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)))))
+  (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)
 
 
 (eval-when (:compile-toplevel :execute)
 

@@ -838,44 +890,78 @@ the first."
     #!+long-float
     ((long-float (foreach single-float double-float))
      (,op x (coerce y 'long-float)))
     #!+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)
     (((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)
     (((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)
 ) ; 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))
   (def-two-arg-</> two-arg-< < floor ceiling
     ((fixnum bignum)
      (bignum-plus-p y))

@@ -894,9 +980,9 @@ the first."
 (defun two-arg-= (x y)
   (number-dispatch ((x number) (y number))
     (basic-compare =
 (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)
     ((fixnum (or bignum ratio)) nil)
 
     ((bignum (or fixnum ratio)) nil)

@@ -906,93 +992,36 @@ the first."
     ((ratio integer) nil)
     ((ratio ratio)
      (and (eql (numerator x) (numerator y))
     ((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))
 
     ((complex complex)
      (and (= (realpart x) (realpart y))

-         (= (imagpart x) (imagpart y))))
+          (= (imagpart x) (imagpart y))))

     (((foreach fixnum bignum ratio single-float double-float
     (((foreach fixnum bignum ratio single-float double-float

-              #!+long-float long-float) complex)
+               #!+long-float long-float) complex)

      (and (= x (realpart y))
      (and (= x (realpart y))

-         (zerop (imagpart y))))
+          (zerop (imagpart y))))

     ((complex (or float rational))
      (and (= (realpart x) 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))))))

 \f
 ;;;; logicals
 
 \f
 ;;;; 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
 
 (defun lognot (number)
   #!+sb-doc

@@ -1002,21 +1031,21 @@ the first."
     (bignum (bignum-logical-not number))))
 
 (macrolet ((def (name op big-op &optional doc)
     (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 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)))
        #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.")
   (def lognor lognor
        (lambda (x y) (lognot (bignum-logical-ior x y)))

@@ -1042,11 +1071,11 @@ the first."
   (etypecase integer
     (fixnum
      (logcount (truly-the (integer 0
   (etypecase integer
     (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))))
+                                   #.(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))))
 
     (bignum
      (bignum-logcount integer))))
 

@@ -1059,9 +1088,9 @@ the first."
   #!+sb-doc
   "Predicate returns T if bit index of integer is a 1."
   (number-dispatch ((index integer) (integer integer))
   #!+sb-doc
   "Predicate returns T if bit index of integer is a 1."
   (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 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))))
 
     ((fixnum bignum) (bignum-logbitp index integer))
     ((bignum (foreach fixnum bignum)) (minusp integer))))
 

@@ -1072,30 +1101,31 @@ the first."
   (etypecase integer
     (fixnum
      (cond ((zerop integer)
   (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
      (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
 
 (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)))
   (etypecase integer
     (fixnum
      (integer-length (truly-the fixnum integer)))

@@ -1146,21 +1176,25 @@ the first."
   (deposit-field newbyte bytespec integer))
 
 (defun %ldb (size posn integer)
   (deposit-field newbyte bytespec integer))
 
 (defun %ldb (size posn integer)

+  (declare (type bit-index size posn))

   (logand (ash integer (- posn))
   (logand (ash integer (- posn))

-         (1- (ash 1 size))))
+          (1- (ash 1 size))))

 
 (defun %mask-field (size posn integer)
 
 (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)
   (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)))
   (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)
 
 (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)
   (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
 
 (defun sb!c::mask-signed-field (size integer)
   #!+sb-doc

@@ -1285,32 +1319,35 @@ the first."
 \f
 ;;;; GCD and LCM
 
 \f
 ;;;; GCD and LCM
 

-(defun gcd (&rest numbers)
+(defun gcd (&rest integers)

   #!+sb-doc
   "Return the greatest common divisor of the arguments, which must be
   #!+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."
   #!+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))
 
 (defun two-arg-lcm (n m)
   (declare (integer n m))

@@ -1321,13 +1358,17 @@ the first."
       ;; 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
       ;; 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))
       (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)))))
+            (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
 
 ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
 ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly

@@ -1336,67 +1377,104 @@ the first."
 ;;; about "small bignum" zeros.
 (defun two-arg-gcd (u v)
   (cond ((eql u 0) (abs v))
 ;;; 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))))))

 \f
 \f

-;;; 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
 (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)))))

 \f
 ;;;; miscellaneous number predicates
 
 (macrolet ((def (name doc)
 \f
 ;;;; 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?")
   (def zerop "Is this number zero?")
   (def plusp "Is this real number strictly positive?")
   (def minusp "Is this real number strictly negative?")

@@ -1406,30 +1484,18 @@ the first."
 ;;;; modular functions
 #.
 (collect ((forms))
 ;;;; 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-class-funs sb!c::*unsigned-modular-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 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)))
-
-#.
-(collect ((forms))
-  (flet ((definition (name lambda-list width)
+  (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))
            `(defun ,name ,lambda-list
               (flet ((prepare-argument (x)
                        (declare (integer x))

@@ -1439,15 +1505,23 @@ the first."
                          (bignum (sb!c::mask-signed-field ,width x)))))
                 (,name ,@(loop for arg in lambda-list
                                collect `(prepare-argument ,arg)))))))
                          (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-class-funs sb!c::*signed-modular-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 lambda-list = (sb!c::modular-fun-info-lambda-list info)
-                   do (forms (definition name lambda-list width)))))
-  `(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
 
 ;;; KLUDGE: these out-of-line definitions can't use the modular
 ;;; arithmetic, as that is only (currently) defined for constant

@@ -1465,10 +1539,11 @@ the first."
     ((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)
     ((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)))))
-
-#!+x86
-(defun sb!vm::ash-left-smod30 (integer amount)
-  (etypecase integer
-    ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
-    (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))
+                 (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))))))