From 87c62dadeba82095c672161e30a3611016d270fb Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 17 Sep 2012 20:46:18 +0300
Subject: [PATCH] don't assume only bits are looked for in bit-vectors

---
 NEWS                               |    2 ++
 src/code/bit-bash.lisp             |    5 +++--
 src/code/seq.lisp                  |    5 +++--
 src/compiler/seqtran.lisp          |   28 ++++++++++++++--------------
 tests/bit-vector.impure-cload.lisp |   22 ++++++++++++++++++++++
 5 files changed, 44 insertions(+), 18 deletions(-)

diff --git a/NEWS b/NEWS
index b56e28d..bdffa5c 100644
--- a/NEWS
+++ b/NEWS
@@ -17,6 +17,8 @@ changes relative to sbcl-1.0.58:
     a SYMBOL-VALUE form with a constant symbol argument.
   * bug fix: SB-EXT:GET-CAS-EXPANSION signaled an error when a macro expanding
     into a DEFCAS defined place was used as the place.
+  * bug fix: FIND and POSITION signaled a type-error when non-bits where looked
+    for from bit-vectors.
   * documentation: a section on random number generation has been added to the
     manual. (lp#656839)
 
diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp
index 30c3c5b..28d9204 100644
--- a/src/code/bit-bash.lisp
+++ b/src/code/bit-bash.lisp
@@ -687,6 +687,7 @@
   (def %bit-position/0 (logandc2 #.(1- (expt 2 n-word-bits))))
   (def %bit-position/1 (identity)))
 (defun %bit-position (bit vector from-end start end)
-  (ecase bit
+  (case bit
     (0 (%bit-position/0 vector from-end start end))
-    (1 (%bit-position/1 vector from-end start end))))
+    (1 (%bit-position/1 vector from-end start end))
+    (otherwise nil)))
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index bc678fd..90036a6 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -2235,11 +2235,12 @@ many elements are copied."
                          ((simple-array base-char (*)) (frob2))
                          ,@(when bit-frob
                              `((simple-bit-vector
-                                (if (and (eq #'identity key)
+                                (if (and (typep item 'bit)
+                                         (eq #'identity key)
                                          (or (eq #'eq test)
                                              (eq #'eql test)
                                              (eq #'equal test)))
-                                    (let ((p (%bit-position (the bit item) sequence
+                                    (let ((p (%bit-position item sequence
                                                             from-end start end)))
                                       (if p
                                           (values item p)
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index ac8cd0f..0b52e48 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1453,20 +1453,20 @@
   (when (or test key)
     (delay-ir1-transform node :optimize)
     (give-up-ir1-transform "non-trivial :KEY or :TEST"))
-  `(with-array-data ((bits sequence :offset-var offset)
-                     (start start)
-                     (end end)
-                     :check-fill-pointer t)
-     (let ((p ,(if (constant-lvar-p item)
-                   (case (lvar-value item)
-                     (0 `(%bit-position/0 bits from-end start end))
-                     (1 `(%bit-position/1 bits from-end start end))
-                     (otherwise
-                      (abort-ir1-transform)))
-                   `(%bit-position (the bit item) bits from-end start end))))
-       (if p
-           (values item (the index (- (truly-the index p) offset)))
-           (values nil nil)))))
+  (catch 'not-a-bit
+    `(with-array-data ((bits sequence :offset-var offset)
+                       (start start)
+                       (end end)
+                       :check-fill-pointer t)
+       (let ((p ,(if (constant-lvar-p item)
+                     (case (lvar-value item)
+                       (0 `(%bit-position/0 bits from-end start end))
+                       (1 `(%bit-position/1 bits from-end start end))
+                       (otherwise (throw 'not-a-bit `(values nil nil))))
+                     `(%bit-position item bits from-end start end))))
+         (if p
+             (values item (the index (- (truly-the index p) offset)))
+             (values nil nil))))))
 
 (deftransform %find-position ((item sequence from-end start end key test)
                               (character string t t t function function)
diff --git a/tests/bit-vector.impure-cload.lisp b/tests/bit-vector.impure-cload.lisp
index 3a92a34..65f075a 100644
--- a/tests/bit-vector.impure-cload.lisp
+++ b/tests/bit-vector.impure-cload.lisp
@@ -85,3 +85,25 @@
            '(and)
            '(or))
 (test-big-bit-vectors)
+
+(with-test (:name :find-non-bit-from-bit-vector)
+  (assert (not (find #\a #*0101)))
+  (assert (not (position #\a #*0101)))
+  (let ((f1 (compile nil
+                     `(lambda (b)
+                        (find b #*0101))))
+        (f2 (compile nil
+                     `(lambda (b)
+                        (position b #*0101)))))
+    (assert (not (funcall f1 t)))
+    (assert (not (funcall f2 t))))
+  (let ((f1 (compile nil
+                     `(lambda (b)
+                        (declare (bit-vector b))
+                        (find t b))))
+        (f2 (compile nil
+                     `(lambda (b)
+                        (declare (bit-vector b))
+                        (position t b)))))
+    (assert (not (funcall f1 #*010101)))
+    (assert (not (funcall f2 #*101010)))))
-- 
1.7.10.4