diff options
author | Daniel Colascione <dancol@dancol.org> | 2013-09-22 01:31:55 -0800 |
---|---|---|
committer | Daniel Colascione <dancol@dancol.org> | 2013-09-22 01:31:55 -0800 |
commit | 3e0b94e7ff1fc69b077322d672ef5d0b668541c3 (patch) | |
tree | 9927abd073960f2460f05a43ae9467cd82c00b9b /test/automated/data-tests.el | |
parent | 76880d884d87d0bc674249e292ccda70f31cca0e (diff) | |
download | emacs-3e0b94e7ff1fc69b077322d672ef5d0b668541c3.tar.gz |
Add set operations for bool-vector.
http://lists.gnu.org/archive/html/emacs-devel/2013-09/msg00404.html
* data.c (Qbool_vector_p): New symbol.
(bool_vector_spare_mask,popcount_size_t_generic)
(popcount_size_t_msc,popcount_size_t_gcc)
(popcount_size_t)
(bool_vector_binop_driver)
(count_trailing_zero_bits,size_t_to_host_endian)
(Fbool_vector_exclusive_or)
(Fbool_vector_union)
(Fbool_vector_intersection,Fbool_vector_set_difference)
(Fbool_vector_subsetp,Fbool_vector_not)
(Fbool_vector_count_matches)
(Fbool_vector_count_matches_at): New functions.
(syms_of_data): Intern new symbol, functions.
* alloc.c (bool_vector_payload_bytes): New function.
(Fmake_bool_vector): Instead of calling Fmake_vector,
which performs redundant initialization and argument checking,
just call allocate_vector ourselves. Make sure we clear any
terminating padding to zero.
(vector_nbytes,sweep_vectors): Use bool_vector_payload_bytes
instead of open-coding the size calculation.
(vroundup_ct): New macro.
(vroundup): Assume argument >= 0; invoke vroundup_ct.
* casetab.c (shuffle,set_identity): Change lint_assume to assume.
* composite.c (composition_gstring_put_cache): Change
lint_assume to assume.
* conf_post.h (assume): New macro.
(lint_assume): Remove.
* dispnew.c (update_frame_1): Change lint_assume to assume.
* ftfont.c (ftfont_shape_by_flt): Change lint_assume
to assume.
* image.c (gif_load): Change lint_assume to assume.
* lisp.h (eassert_and_assume): New macro.
(Qbool_vector_p): Declare.
(CHECK_BOOL_VECTOR,ROUNDUP,BITS_PER_SIZE_T): New macros.
(swap16,swap32,swap64): New inline functions.
* macfont.c (macfont_shape): Change lint_assume to assume.
* ralloc.c: Rename ROUNDUP to PAGE_ROUNDUP throughout.
* xsettings.c (parse_settings): Use new swap16 and
swap32 from lisp.h instead of file-specific macros.
Diffstat (limited to 'test/automated/data-tests.el')
-rw-r--r-- | test/automated/data-tests.el | 186 |
1 files changed, 185 insertions, 1 deletions
diff --git a/test/automated/data-tests.el b/test/automated/data-tests.el index 2298fa3fe71..d79e1643848 100644 --- a/test/automated/data-tests.el +++ b/test/automated/data-tests.el @@ -21,6 +21,9 @@ ;;; Code: +(require 'cl-lib) +(eval-when-compile (require 'cl)) + (ert-deftest data-tests-= () (should-error (=)) (should (= 1)) @@ -71,5 +74,186 @@ ;; Short circuits before getting to bad arg (should-not (>= 8 9 'foo))) -;;; data-tests.el ends here +;; Bool vector tests. Compactly represent bool vectors as hex +;; strings. + +(ert-deftest bool-vector-count-matches-all-0-nil () + (cl-loop for sz in '(0 45 1 64 9 344) + do (let* ((bv (make-bool-vector sz nil))) + (should + (eql + (bool-vector-count-matches bv nil) + sz))))) + +(ert-deftest bool-vector-count-matches-all-0-t () + (cl-loop for sz in '(0 45 1 64 9 344) + do (let* ((bv (make-bool-vector sz nil))) + (should + (eql + (bool-vector-count-matches bv t) + 0))))) + +(ert-deftest bool-vector-count-matches-1-nil () + (let* ((bv (make-bool-vector 45 nil))) + (aset bv 40 t) + (aset bv 0 t) + (should + (eql + (bool-vector-count-matches bv t) + 2))) + ) + +(ert-deftest bool-vector-count-matches-1-t () + (let* ((bv (make-bool-vector 45 nil))) + (aset bv 40 t) + (aset bv 0 t) + (should + (eql + (bool-vector-count-matches bv nil) + 43)))) + +(defun mock-bool-vector-count-matches-at (a b i) + (loop for i from i below (length a) + while (eq (aref a i) b) + sum 1)) + +(defun test-bool-vector-bv-from-hex-string (desc) + (let (bv nchars nibbles) + (dolist (c (string-to-list desc)) + (push (string-to-number + (char-to-string c) + 16) + nibbles)) + (setf bv (make-bool-vector (* 4 (length nibbles)) nil)) + (let ((i 0)) + (dolist (n (nreverse nibbles)) + (dotimes (_ 4) + (aset bv i (> (logand 1 n) 0)) + (incf i) + (setf n (lsh n -1))))) + bv)) + +(defun test-bool-vector-to-hex-string (bv) + (let (nibbles (v (cl-coerce bv 'list))) + (while v + (push (logior + (lsh (if (nth 0 v) 1 0) 0) + (lsh (if (nth 1 v) 1 0) 1) + (lsh (if (nth 2 v) 1 0) 2) + (lsh (if (nth 3 v) 1 0) 3)) + nibbles) + (setf v (nthcdr 4 v))) + (mapconcat (lambda (n) (format "%X" n)) + (nreverse nibbles) + ""))) + +(defun test-bool-vector-count-matches-at-tc (desc) + "Run a test case for bool-vector-count-matches-at. +DESC is a string describing the test. It is a sequence of +hexadecimal digits describing the bool vector. We exhaustively +test all counts at all possible positions in the vector by +comparing the subr with a much slower lisp implementation." + (let ((bv (test-bool-vector-bv-from-hex-string desc))) + (loop + for lf in '(nil t) + do (loop + for pos from 0 upto (length bv) + for cnt = (mock-bool-vector-count-matches-at bv lf pos) + for rcnt = (bool-vector-count-matches-at bv lf pos) + unless (eql cnt rcnt) + do (error "FAILED testcase %S %3S %3S %3S" + pos lf cnt rcnt))))) + +(defconst bool-vector-test-vectors +'("" + "0" + "F" + "0F" + "F0" + "00000000000000000000000000000FFFFF0000000" + "44a50234053fba3340000023444a50234053fba33400000234" + "12341234123456123412346001234123412345612341234600" + "44a50234053fba33400000234" + "1234123412345612341234600" + "44a50234053fba33400000234" + "1234123412345612341234600" + "44a502340" + "123412341" + "0000000000000000000000000" + "FFFFFFFFFFFFFFFF1")) + +(ert-deftest bool-vector-count-matches-at () + (mapc #'test-bool-vector-count-matches-at-tc + bool-vector-test-vectors)) + +(defun test-bool-vector-apply-mock-op (mock a b c) + "Compute (slowly) the correct result of a bool-vector set operation." + (let (changed nv) + (assert (eql (length b) (length c))) + (if a (setf nv a) + (setf a (make-bool-vector (length b) nil)) + (setf changed t)) + + (loop for i below (length b) + for mockr = (funcall mock + (if (aref b i) 1 0) + (if (aref c i) 1 0)) + for r = (not (= 0 mockr)) + do (progn + (unless (eq (aref a i) r) + (setf changed t)) + (setf (aref a i) r))) + (if changed a))) + +(defun test-bool-vector-binop (mock real) + "Test a binary set operation." + (loop for s1 in bool-vector-test-vectors + for bv1 = (test-bool-vector-bv-from-hex-string s1) + for vecs2 = (cl-remove-if-not + (lambda (x) (eql (length x) (length s1))) + bool-vector-test-vectors) + do (loop for s2 in vecs2 + for bv2 = (test-bool-vector-bv-from-hex-string s2) + for mock-result = (test-bool-vector-apply-mock-op + mock nil bv1 bv2) + for real-result = (funcall real bv1 bv2) + do (progn + (should (equal mock-result real-result)))))) + +(ert-deftest bool-vector-intersection-op () + (test-bool-vector-binop + #'logand + #'bool-vector-intersection)) + +(ert-deftest bool-vector-union-op () + (test-bool-vector-binop + #'logior + #'bool-vector-union)) + +(ert-deftest bool-vector-xor-op () + (test-bool-vector-binop + #'logxor + #'bool-vector-exclusive-or)) + +(ert-deftest bool-vector-set-difference-op () + (test-bool-vector-binop + (lambda (a b) (logand a (lognot b))) + #'bool-vector-set-difference)) + +(ert-deftest bool-vector-change-detection () + (let* ((vc1 (test-bool-vector-bv-from-hex-string "abcdef")) + (vc2 (test-bool-vector-bv-from-hex-string "012345")) + (vc3 (make-bool-vector (length vc1) nil)) + (c1 (bool-vector-union vc1 vc2 vc3)) + (c2 (bool-vector-union vc1 vc2 vc3))) + (should (equal c1 (test-bool-vector-apply-mock-op + #'logior + nil + vc1 vc2))) + (should (not c2)))) +(ert-deftest bool-vector-not () + (let* ((v1 (test-bool-vector-bv-from-hex-string "FFFF3")) + (v2 (test-bool-vector-bv-from-hex-string "0000C")) + (v3 (bool-vector-not v1))) + (should (equal v2 v3)))) |