Permalink
Browse files

don't assume only bits are looked for in bit-vectors

  • Loading branch information...
nikodemus committed Sep 17, 2012
1 parent 7c9bae1 commit 87c62dadeba82095c672161e30a3611016d270fb
Showing with 44 additions and 18 deletions.
  1. +2 −0 NEWS
  2. +3 −2 src/code/bit-bash.lisp
  3. +3 −2 src/code/seq.lisp
  4. +14 −14 src/compiler/seqtran.lisp
  5. +22 −0 tests/bit-vector.impure-cload.lisp
View
2 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)
View
@@ -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)))
View
@@ -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)
View
@@ -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)
@@ -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)))))

0 comments on commit 87c62da

Please sign in to comment.