X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=25c604625fa8145ed8a18983c2ef50092ed898cc;hb=512c78f5f0c8e4c11bad219313dd83890f625006;hp=fe6f9d1e2d409959114f27a9478a3624edd95d9d;hpb=3254e1b6fb33e4ff5be5f37ba4bbcc34ca151cf7;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index fe6f9d1..25c6046 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))))
 
@@ -1496,14 +1544,9 @@ the first."
     (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)))))
-
-#!+x86-64
-(defun sb!vm::ash-left-smod61 (integer amount)
-  (etypecase integer
-    ((signed-byte 61) (sb!c::mask-signed-field 61 (ash integer amount)))
-    (integer (sb!c::mask-signed-field 61 (ash (sb!c::mask-signed-field 61 integer) 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))))))