From f846a7a310d630cf538811959916492a28a75fb1 Mon Sep 17 00:00:00 2001
From: Alexey Dejneka <adejneka@comail.ru>
Date: Sun, 20 Feb 2005 18:53:13 +0000
Subject: [PATCH] 0.8.19.34:         * Fix MISC.527: DEFTRANSFORM for BIT-AND
 and similar for           vectors use (ARRAY-DIMENSION v 0)
 instead if LENGTH to get           the full vector size.

---
 NEWS                         |    2 ++
 OPTIMIZATIONS                |   15 +++++++++++++++
 src/compiler/array-tran.lisp |    4 ++--
 tests/array.pure.lisp        |   32 ++++++++++++++++++++++++++++++++
 version.lisp-expr            |    3 +--
 5 files changed, 52 insertions(+), 4 deletions(-)

diff --git a/NEWS b/NEWS
index 8c3e23a..0a9217b 100644
--- a/NEWS
+++ b/NEWS
@@ -58,6 +58,8 @@ changes in sbcl-0.8.20 (0.9alpha.0?) relative to sbcl-0.8.19:
        normal termination.
     ** Pretty-printing backquoted forms when *PRINT-CIRCLE* is true
        works more reliably.
+    ** Bit-array operations (BIT-AND and similar) worked incorrectly
+       with one-dimensional arrays with fill pointers.
 
 changes in sbcl-0.8.19 relative to sbcl-0.8.18:
   * new port: SBCL now works in native 64-bit mode on x86-64/Linux
diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS
index 50d3417..53438ab 100644
--- a/OPTIMIZATIONS
+++ b/OPTIMIZATIONS
@@ -217,3 +217,18 @@ of (and (or (not number) fixnum) (not character))
 
 This sitation where the type is (OR NULL FIXNUM) comes up
 in cl-bench, for example in the value returned by POSITION.
+--------------------------------------------------------------------------------
+#26
+SBCL cannot derive upper bound for I and uses generic arithmetic here:
+
+(defun foo (l)
+  (declare (vector l))
+  (dotimes (i (length l))
+    (if (block nil
+          (map-foo (lambda (x) (if x (return t)))
+                   l))
+        t
+        nil)))
+
+(So the constraint propagator or a possible future SSA-convertor
+should know the connection between an NLE and its CLEANUP.)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 0c52b81..ab21afa 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -757,7 +757,7 @@
                                    (bit-vector bit-vector &optional null) *
                                    :policy (>= speed space))
                  `(,',fun bit-array-1 bit-array-2
-                   (make-array (length bit-array-1) :element-type 'bit)))
+                   (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
                ;; If result is T, make it the first arg.
                (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array)
                                    (bit-vector bit-vector (eql t)) *)
@@ -778,7 +778,7 @@
 		       (bit-vector &optional null) *
 		       :policy (>= speed space))
   '(bit-not bit-array-1
-	    (make-array (length bit-array-1) :element-type 'bit)))
+	    (make-array (array-dimension bit-array-1 0) :element-type 'bit)))
 (deftransform bit-not ((bit-array-1 result-bit-array)
 		       (bit-vector (eql t)))
   '(bit-not bit-array-1 bit-array-1))
diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp
index 25d7bea..d3dc6cd 100644
--- a/tests/array.pure.lisp
+++ b/tests/array.pure.lisp
@@ -173,3 +173,35 @@
 	  (adjust-array x '(5))
 	  (char y 5))))
   (assert (and (not val) (typep err 'sb-kernel:displaced-to-array-too-small-error))))
+
+;;; MISC.527: bit-vector bitwise operations used LENGTH to get a size
+;;; of a vector
+(flet ((bit-vector-equal (v1 v2)
+         (and (bit-vector-p v1) (bit-vector-p v2)
+              (equal (array-dimension v1 0) (array-dimension v2 0))
+              (loop for i below (array-dimension v1 0)
+                    always (eql (aref v1 i) (aref v2 i))))))
+  (let ((v1 (make-array 4 :element-type 'bit :fill-pointer 0
+                        :initial-contents '(0 0 1 1)))
+        (v2 (make-array 4 :element-type 'bit :fill-pointer 1
+                        :initial-contents '(0 0 1 1))))
+    (loop for (bf lf) in '((bit-and logand)
+                           (bit-andc1 logandc1)
+                           (bit-andc2 logandc2)
+                           (bit-eqv logeqv)
+                           (bit-ior logior)
+                           (bit-nand lognand)
+                           (bit-nor lognor)
+                           (bit-orc1 logorc1)
+                           (bit-orc2 logorc2)
+                           (bit-xor logxor)
+                           ((lambda (x y) (bit-not x)) #.(lambda (x y) (lognot x))))
+          for fun = (compile nil `(lambda (v)
+                                    (declare (type (array bit (*)) v))
+                                    (declare (optimize (speed 3) (safety 0)))
+                                    (,bf v ,v2)))
+          for r1 = (funcall fun v1)
+          and r2 = (coerce (loop for i below 4
+                                 collect (logand 1 (funcall lf (aref v1 i) (aref v2 i))))
+                           'bit-vector)
+          do (assert (bit-vector-equal r1 r2)))))
diff --git a/version.lisp-expr b/version.lisp-expr
index a53bf94..9268c98 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,5 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.19.33"
-
+"0.8.19.34"
-- 
1.7.10.4