+ (with-input-from-string (s string :start 6 :end 9)
+ (read-char s)))))
+\f
+;;; testing bit-bashing according to _The Practice of Programming_
+(defun fill-bytes-for-testing (bitsize)
+ "Return a list of 'bytes' of type (MOD BITSIZE)."
+ (remove-duplicates (list 0
+ (1- (ash 1 (1- bitsize)))
+ (ash 1 (1- bitsize))
+ (1- (ash 1 bitsize)))))
+
+(defun fill-with-known-value (value size &rest vectors)
+ (dolist (vec vectors)
+ (dotimes (i size)
+ (setf (aref vec i) value))))
+
+(defun collect-fill-amounts (n-power)
+ (remove-duplicates
+ (loop for i from 0 upto n-power
+ collect (1- (expt 2 i))
+ collect (expt 2 i)
+ collect (1+ (expt 2 i)))))
+
+(defun test-fill-bashing (bitsize padding-amount n-power)
+ (let* ((size (+ (* padding-amount 2) (expt 2 n-power) (* padding-amount 2)))
+ (standard (make-array size :element-type `(unsigned-byte ,bitsize)))
+ (bashed (make-array size :element-type `(unsigned-byte ,bitsize)))
+ (fill-amounts (collect-fill-amounts n-power))
+ (bash-function (intern (format nil "UB~A-BASH-FILL" bitsize)
+ (find-package "SB-KERNEL"))))
+ (format t "~&/Function ~A..." bash-function)
+ (loop for offset from padding-amount below (* 2 padding-amount) do
+ (dolist (c (fill-bytes-for-testing bitsize))
+ (dolist (n fill-amounts)
+ (fill-with-known-value (mod (lognot c) (ash 1 bitsize)) n
+ standard bashed)
+ ;; fill vectors
+ ;; a) the standard slow way
+ (fill standard c :start offset :end (+ offset n))
+ ;; b) the blazingly fast way
+ (let ((value (loop for i from 0 by bitsize
+ until (= i sb-vm:n-word-bits)
+ sum (ash c i))))
+ (funcall bash-function value bashed offset n))
+ ;; check for errors
+ (when (mismatch standard bashed)
+ (format t "Test with offset ~A, fill ~A and length ~A failed.~%"
+ offset c n)
+ (format t "Mismatch: ~A ~A~%"
+ (subseq standard 0 (+ offset n 1))
+ (subseq bashed 0 (+ offset n 1)))
+ (return-from test-fill-bashing nil))))
+ finally (return t))))
+
+(defun test-copy-bashing (bitsize padding-amount n-power)
+ (let* ((size (+ (* padding-amount 2) (expt 2 n-power) (* padding-amount 2)))
+ (standard-dst (make-array size :element-type `(unsigned-byte ,bitsize)))
+ (bashed-dst (make-array size :element-type `(unsigned-byte ,bitsize)))
+ (source (make-array size :element-type `(unsigned-byte ,bitsize)))
+ (fill-amounts (collect-fill-amounts n-power))
+ (bash-function (intern (format nil "UB~A-BASH-COPY" bitsize)
+ (find-package "SB-KERNEL"))))
+ (format t "~&/Function ~A..." bash-function)
+ (do ((source-offset padding-amount (1+ source-offset)))
+ ((>= source-offset (* padding-amount 2))
+ ;; success!
+ t)
+ (do ((target-offset padding-amount (1+ target-offset)))
+ ((>= target-offset (* padding-amount 2)))
+ (dolist (c (fill-bytes-for-testing bitsize))
+ (dolist (n fill-amounts)
+ (fill-with-known-value (mod (lognot c) (ash 1 bitsize)) size
+ source standard-dst bashed-dst)
+ ;; fill with test data
+ (fill source c :start source-offset :end (+ source-offset n))
+ ;; copy filled test data to test vectors
+ ;; a) the slow way
+ (replace standard-dst source
+ :start1 target-offset :end1 (+ target-offset n)
+ :start2 source-offset :end2 (+ source-offset n))
+ ;; b) the blazingly fast way
+ (funcall bash-function source source-offset
+ bashed-dst target-offset n)
+ ;; check for errors
+ (when (mismatch standard-dst bashed-dst)
+ (format t "Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
+ target-offset source-offset c n)
+ (format t "Mismatch:~% correct ~A~% actual ~A~%"
+ standard-dst
+ bashed-dst)
+ (return-from test-copy-bashing nil))))))))
+
+;; Too slow for the interpreter
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
+(loop for i = 1 then (* i 2) do
+ ;; the bare '13' here is fairly arbitrary, except that it's been
+ ;; reduced from '32', which made the tests take aeons; '8' provides
+ ;; a good range of lengths over which to fill and copy, which
+ ;; should tease out most errors in the code (if any exist). (It
+ ;; also makes this part of the test suite finish reasonably
+ ;; quickly.)
+ (assert (time (test-fill-bashing i 13 8)))
+ (assert (time (test-copy-bashing i 13 8)))
+ until (= i sb-vm:n-word-bits))
+
+(defun test-inlined-bashing (bitsize)
+ ;; We have to compile things separately for each bitsize so the
+ ;; compiler will work out the array type and trigger the REPLACE
+ ;; transform.
+ (let ((lambda-form
+ `(lambda ()
+ (let* ((n-elements-per-word ,(truncate sb-vm:n-word-bits bitsize))
+ (size (* 3 n-elements-per-word))
+ (standard-dst (make-array size :element-type '(unsigned-byte ,bitsize)))
+ (bashed-dst (make-array size :element-type '(unsigned-byte ,bitsize)))
+ (source (make-array size :element-type '(unsigned-byte ,bitsize))))
+ (declare (type (simple-array (unsigned-byte ,bitsize) (*))
+ source standard-dst bashed-dst))
+ (do ((i 0 (1+ i))
+ (offset n-elements-per-word (1+ offset)))
+ ((>= offset (* 2 n-elements-per-word)) t)
+ (dolist (c (fill-bytes-for-testing ,bitsize))
+ (fill-with-known-value (mod (lognot c) (ash 1 ,bitsize)) size
+ source standard-dst bashed-dst)
+ ;; fill with test-data
+ (fill source c :start offset :end (+ offset n-elements-per-word))
+ ;; copy filled data to test vectors
+ ;;
+ ;; a) the slow way (which is actually fast, since this
+ ;; should be transformed into UB*-BASH-COPY)
+ (replace standard-dst source
+ :start1 (- offset n-elements-per-word i)
+ :start2 (- offset n-elements-per-word i)
+ :end1 offset :end2 offset)
+ ;; b) the fast way--we fold the
+ ;; :START{1,2} arguments above ourselves
+ ;; to trigger the REPLACE transform
+ (replace bashed-dst source
+ :start1 0 :start2 0 :end1 offset :end2 offset)
+ ;; check for errors
+ (when (or (mismatch standard-dst bashed-dst)
+ ;; trigger COPY-SEQ transform
+ (mismatch (copy-seq standard-dst) bashed-dst)
+ ;; trigger SUBSEQ transform
+ (mismatch (subseq standard-dst (- offset n-elements-per-word i))
+ bashed-dst))
+ (format t "Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
+ 0 0 c offset)
+ (format t "Mismatch:~% correct ~A~% actual ~A~%"
+ standard-dst
+ bashed-dst)
+ (return-from nil nil))))))))
+ (funcall (compile nil lambda-form))))
+
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
+(loop for i = 1 then (* i 2) do
+ (assert (test-inlined-bashing i))
+ until (= i sb-vm:n-word-bits))
+\f
+;;; tests from the Sacla test suite via Eric Marsden, 2007-05-07
+(remove-duplicates (vector 1 2 2 1) :test-not (lambda (a b) (not (= a b))))
+
+(delete-duplicates (vector #\a #\b #\c #\a)
+ :test-not (lambda (a b) (not (char-equal a b))))