+ '((unless (= (length bit-array)
+ (length result-bit-array))
+ (error "Argument and result bit arrays are not the same length:~
+ ~% ~S~% ~S"
+ bit-array result-bit-array))))
+ (let ((length (length result-bit-array)))
+ (if (= length 0)
+ ;; We avoid doing anything to 0-length bit-vectors, or rather,
+ ;; the memory that follows them. Other divisible-by
+ ;; n-word-bits cases are handled by the (1- length), below.
+ ;; CSR, 2002-04-24
+ result-bit-array
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (end-1 (+ sb!vm:vector-data-offset
+ ;; bit-vectors of length 1 to n-word-bits need
+ ;; precisely one (SETF %RAW-BITS), done here in
+ ;; the epilogue. - CSR, 2002-04-24
+ (truncate (truly-the index (1- length))
+ sb!vm:n-word-bits))))
+ ((>= index end-1)
+ (setf (%raw-bits result-bit-array index)
+ (word-logical-not (%raw-bits bit-array index)))
+ result-bit-array)
+ (declare (optimize (speed 3) (safety 0))
+ (type index index end-1))
+ (setf (%raw-bits result-bit-array index)
+ (word-logical-not (%raw-bits bit-array index))))))))
+
+(deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector))
+ `(and (= (length x) (length y))
+ (let ((length (length x)))
+ (or (= length 0)
+ (do* ((i sb!vm:vector-data-offset (+ i 1))
+ (end-1 (+ sb!vm:vector-data-offset
+ (floor (1- length) sb!vm:n-word-bits))))
+ ((>= i end-1)
+ (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
+ (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
+ (- extra sb!vm:n-word-bits)))
+ (numx
+ (logand
+ (ash mask
+ ,(ecase sb!c:*backend-byte-order*
+ (:little-endian 0)
+ (:big-endian
+ '(- sb!vm:n-word-bits extra))))
+ (%raw-bits x i)))
+ (numy
+ (logand
+ (ash mask
+ ,(ecase sb!c:*backend-byte-order*
+ (:little-endian 0)
+ (:big-endian
+ '(- sb!vm:n-word-bits extra))))
+ (%raw-bits y i))))
+ (declare (type (integer 1 #.sb!vm:n-word-bits) extra)
+ (type sb!vm:word mask numx numy))
+ (= numx numy)))
+ (declare (type index i end-1))
+ (let ((numx (%raw-bits x i))
+ (numy (%raw-bits y i)))
+ (declare (type sb!vm:word numx numy))
+ (unless (= numx numy)
+ (return nil))))))))
+
+(deftransform count ((item sequence) (bit simple-bit-vector) *
+ :policy (>= speed space))
+ `(let ((length (length sequence)))
+ (if (zerop length)
+ 0
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (count 0)
+ (end-1 (+ sb!vm:vector-data-offset
+ (truncate (truly-the index (1- length))
+ sb!vm:n-word-bits))))
+ ((>= index end-1)
+ (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
+ (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
+ (- extra sb!vm:n-word-bits)))
+ (bits (logand (ash mask
+ ,(ecase sb!c:*backend-byte-order*
+ (:little-endian 0)
+ (:big-endian
+ '(- sb!vm:n-word-bits extra))))
+ (%raw-bits sequence index))))
+ (declare (type (integer 1 #.sb!vm:n-word-bits) extra))
+ (declare (type sb!vm:word mask bits))
+ (incf count (logcount bits))
+ ,(if (constant-lvar-p item)
+ (if (zerop (lvar-value item))
+ '(- length count)
+ 'count)
+ '(if (zerop item)
+ (- length count)
+ count))))
+ (declare (type index index count end-1)
+ (optimize (speed 3) (safety 0)))
+ (incf count (logcount (%raw-bits sequence index)))))))
+
+(deftransform fill ((sequence item) (simple-bit-vector bit) *
+ :policy (>= speed space))
+ (let ((value (if (constant-lvar-p item)
+ (if (= (lvar-value item) 0)
+ 0
+ #.(1- (ash 1 sb!vm:n-word-bits)))
+ `(if (= item 0) 0 #.(1- (ash 1 sb!vm:n-word-bits))))))
+ `(let ((length (length sequence))
+ (value ,value))
+ (if (= length 0)
+ sequence
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (end-1 (+ sb!vm:vector-data-offset
+ ;; bit-vectors of length 1 to n-word-bits need
+ ;; precisely one (SETF %RAW-BITS), done here
+ ;; in the epilogue. - CSR, 2002-04-24
+ (truncate (truly-the index (1- length))
+ sb!vm:n-word-bits))))
+ ((>= index end-1)
+ (setf (%raw-bits sequence index) value)
+ sequence)
+ (declare (optimize (speed 3) (safety 0))
+ (type index index end-1))
+ (setf (%raw-bits sequence index) value))))))
+
+(deftransform fill ((sequence item) (simple-base-string base-char) *
+ :policy (>= speed space))
+ (let ((value (if (constant-lvar-p item)
+ (let* ((char (lvar-value item))
+ (code (sb!xc:char-code char))
+ (accum 0))
+ (dotimes (i sb!vm:n-word-bytes accum)
+ (setf accum (logior accum (ash code (* 8 i))))))
+ `(let ((code (sb!xc:char-code item)))
+ (logior ,@(loop for i from 0 below sb!vm:n-word-bytes
+ collect `(ash code ,(* 8 i))))))))
+ `(let ((length (length sequence))
+ (value ,value))
+ (multiple-value-bind (times rem)
+ (truncate length sb!vm:n-word-bytes)
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (end (+ times sb!vm:vector-data-offset)))
+ ((>= index end)
+ (let ((place (* times sb!vm:n-word-bytes)))
+ (declare (fixnum place))
+ (dotimes (j rem sequence)
+ (declare (index j))
+ (setf (schar sequence (the index (+ place j))) item))))
+ (declare (optimize (speed 3) (safety 0))
+ (type index index))
+ (setf (%raw-bits sequence index) value))))))