X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=2b86681fe3a62d6691c8eefb8b27a92a738bd8de;hb=d720bc359f03734ccb9baf66cb45dc01d623f369;hp=b6ba6a2185feca29d4c87253757d711b41f5877e;hpb=e9984509712529c60d1158d44207d6abf11dccce;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index b6ba6a2..2b86681 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -62,10 +62,51 @@
 
 ;;; 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)))
+        (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)
@@ -92,6 +133,13 @@
 ;;; 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))
@@ -1085,9 +1133,9 @@ the first."
   #!+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))))
 
@@ -1400,26 +1448,26 @@ the first."
            ((fixnum bignum)
             (bignum-gcd (make-small-bignum u) v))))))
 
-;;;; from Robert Smith
+;;;; from Robert Smith; slightly changed not to cons unnecessarily.
 (defun isqrt (n)
   #!+sb-doc
-  "Return the root of the nearest integer less than n which is a perfect
-   square."
+  "Return the greatest integer less than or equal to the square root of N."
   (declare (type unsigned-byte n))
   (cond
     ((> n 24)
      (let* ((n-fourth-size (ash (1- (integer-length n)) -2))
             (n-significant-half (ash n (- (ash n-fourth-size 1))))
             (n-significant-half-isqrt (isqrt n-significant-half))
-            (zeroth-iteration (ash n-significant-half-isqrt n-fourth-size))
-            (qr (multiple-value-list (floor n zeroth-iteration)))
-            (first-iteration (ash (+ zeroth-iteration (first qr)) -1)))
-       (cond ((oddp (first qr))
-              first-iteration)
-             ((> (expt (- first-iteration zeroth-iteration) 2) (second qr))
-              (1- first-iteration))
-             (t
-              first-iteration))))
+            (zeroth-iteration (ash n-significant-half-isqrt n-fourth-size)))
+       (multiple-value-bind (quot rem)
+           (floor n zeroth-iteration)
+         (let ((first-iteration (ash (+ zeroth-iteration quot) -1)))
+           (cond ((oddp quot)
+                  first-iteration)
+                 ((> (expt (- first-iteration zeroth-iteration) 2) rem)
+                  (1- first-iteration))
+                 (t
+                  first-iteration))))))
     ((> n 15) 4)
     ((> n  8) 3)
     ((> n  3) 2)