code.delx.au - gnu-emacs/blob - test/automated/data-tests.el

   1 ;;; data-tests.el --- tests for src/data.c
   2
   3 ;; Copyright (C) 2013 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; This program is free software: you can redistribute it and/or
   8 ;; modify it under the terms of the GNU General Public License as
   9 ;; published by the Free Software Foundation, either version 3 of the
  10 ;; License, or (at your option) any later version.
  11 ;;
  12 ;; This program is distributed in the hope that it will be useful, but
  13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;; General Public License for more details.
  16 ;;
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
  19
  20 ;;; Commentary:
  21
  22 ;;; Code:
  23
  24 (require 'cl-lib)
  25 (eval-when-compile (require 'cl))
  26
  27 (ert-deftest data-tests-= ()
  28   (should-error (=))
  29   (should (= 1))
  30   (should (= 2 2))
  31   (should (= 9 9 9 9 9 9 9 9 9))
  32   (should-not (apply #'= '(3 8 3)))
  33   (should-error (= 9 9 'foo))
  34   ;; Short circuits before getting to bad arg
  35   (should-not (= 9 8 'foo)))
  36
  37 (ert-deftest data-tests-< ()
  38   (should-error (<))
  39   (should (< 1))
  40   (should (< 2 3))
  41   (should (< -6 -1 0 2 3 4 8 9 999))
  42   (should-not (apply #'< '(3 8 3)))
  43   (should-error (< 9 10 'foo))
  44   ;; Short circuits before getting to bad arg
  45   (should-not (< 9 8 'foo)))
  46
  47 (ert-deftest data-tests-> ()
  48   (should-error (>))
  49   (should (> 1))
  50   (should (> 3 2))
  51   (should (> 6 1 0 -2 -3 -4 -8 -9 -999))
  52   (should-not (apply #'> '(3 8 3)))
  53   (should-error (> 9 8 'foo))
  54   ;; Short circuits before getting to bad arg
  55   (should-not (> 8 9 'foo)))
  56
  57 (ert-deftest data-tests-<= ()
  58   (should-error (<=))
  59   (should (<= 1))
  60   (should (<= 2 3))
  61   (should (<= -6 -1 -1 0 0 0 2 3 4 8 999))
  62   (should-not (apply #'<= '(3 8 3 3)))
  63   (should-error (<= 9 10 'foo))
  64   ;; Short circuits before getting to bad arg
  65   (should-not (<= 9 8 'foo)))
  66
  67 (ert-deftest data-tests->= ()
  68   (should-error (>=))
  69   (should (>= 1))
  70   (should (>= 3 2))
  71   (should (>= 666 1 0 0 -2 -3 -3 -3 -4 -8 -8 -9 -999))
  72   (should-not (apply #'>= '(3 8 3)))
  73   (should-error (>= 9 8 'foo))
  74   ;; Short circuits before getting to bad arg
  75   (should-not (>= 8 9 'foo)))
  76
  77 ;; Bool vector tests.  Compactly represent bool vectors as hex
  78 ;; strings.
  79
  80 (ert-deftest bool-vector-count-matches-all-0-nil ()
  81   (cl-loop for sz in '(0 45 1 64 9 344)
  82            do (let* ((bv (make-bool-vector sz nil)))
  83                 (should
  84                  (eql
  85                   (bool-vector-count-matches bv nil)
  86                   sz)))))
  87
  88 (ert-deftest bool-vector-count-matches-all-0-t ()
  89   (cl-loop for sz in '(0 45 1 64 9 344)
  90            do (let* ((bv (make-bool-vector sz nil)))
  91                 (should
  92                  (eql
  93                   (bool-vector-count-matches bv t)
  94                   0)))))
  95
  96 (ert-deftest bool-vector-count-matches-1-nil ()
  97   (let* ((bv (make-bool-vector 45 nil)))
  98     (aset bv 40 t)
  99     (aset bv 0 t)
 100     (should
 101      (eql
 102       (bool-vector-count-matches bv t)
 103       2)))
 104   )
 105
 106 (ert-deftest bool-vector-count-matches-1-t ()
 107   (let* ((bv (make-bool-vector 45 nil)))
 108     (aset bv 40 t)
 109     (aset bv 0 t)
 110     (should
 111      (eql
 112       (bool-vector-count-matches bv nil)
 113       43))))
 114
 115 (defun mock-bool-vector-count-matches-at (a b i)
 116   (loop for i from i below (length a)
 117         while (eq (aref a i) b)
 118         sum 1))
 119
 120 (defun test-bool-vector-bv-from-hex-string (desc)
 121   (let (bv nchars nibbles)
 122     (dolist (c (string-to-list desc))
 123       (push (string-to-number
 124              (char-to-string c)
 125              16)
 126             nibbles))
 127     (setf bv (make-bool-vector (* 4 (length nibbles)) nil))
 128     (let ((i 0))
 129       (dolist (n (nreverse nibbles))
 130         (dotimes (_ 4)
 131           (aset bv i (> (logand 1 n) 0))
 132           (incf i)
 133           (setf n (lsh n -1)))))
 134     bv))
 135
 136 (defun test-bool-vector-to-hex-string (bv)
 137   (let (nibbles (v (cl-coerce bv 'list)))
 138     (while v
 139       (push (logior
 140              (lsh (if (nth 0 v) 1 0) 0)
 141              (lsh (if (nth 1 v) 1 0) 1)
 142              (lsh (if (nth 2 v) 1 0) 2)
 143              (lsh (if (nth 3 v) 1 0) 3))
 144             nibbles)
 145       (setf v (nthcdr 4 v)))
 146     (mapconcat (lambda (n) (format "%X" n))
 147                (nreverse nibbles)
 148                "")))
 149
 150 (defun test-bool-vector-count-matches-at-tc (desc)
 151   "Run a test case for bool-vector-count-matches-at.
 152 DESC is a string describing the test.  It is a sequence of
 153 hexadecimal digits describing the bool vector.  We exhaustively
 154 test all counts at all possible positions in the vector by
 155 comparing the subr with a much slower lisp implementation."
 156   (let ((bv (test-bool-vector-bv-from-hex-string desc)))
 157     (loop
 158      for lf in '(nil t)
 159      do (loop
 160          for pos from 0 upto (length bv)
 161          for cnt = (mock-bool-vector-count-matches-at bv lf pos)
 162          for rcnt = (bool-vector-count-matches-at bv lf pos)
 163          unless (eql cnt rcnt)
 164          do (error "FAILED testcase %S %3S %3S %3S"
 165                    pos lf cnt rcnt)))))
 166
 167 (defconst bool-vector-test-vectors
 168 '(""
 169   "0"
 170   "F"
 171   "0F"
 172   "F0"
 173   "00000000000000000000000000000FFFFF0000000"
 174   "44a50234053fba3340000023444a50234053fba33400000234"
 175   "12341234123456123412346001234123412345612341234600"
 176   "44a50234053fba33400000234"
 177   "1234123412345612341234600"
 178   "44a50234053fba33400000234"
 179   "1234123412345612341234600"
 180   "44a502340"
 181   "123412341"
 182   "0000000000000000000000000"
 183   "FFFFFFFFFFFFFFFF1"))
 184
 185 (ert-deftest bool-vector-count-matches-at ()
 186   (mapc #'test-bool-vector-count-matches-at-tc
 187         bool-vector-test-vectors))
 188
 189 (defun test-bool-vector-apply-mock-op (mock a b c)
 190   "Compute (slowly) the correct result of a bool-vector set operation."
 191   (let (changed nv)
 192     (assert (eql (length b) (length c)))
 193     (if a (setf nv a)
 194       (setf a (make-bool-vector (length b) nil))
 195       (setf changed t))
 196
 197     (loop for i below (length b)
 198           for mockr = (funcall mock
 199                                (if (aref b i) 1 0)
 200                                (if (aref c i) 1 0))
 201           for r = (not (= 0 mockr))
 202           do (progn
 203                (unless (eq (aref a i) r)
 204                  (setf changed t))
 205                (setf (aref a i) r)))
 206     (if changed a)))
 207
 208 (defun test-bool-vector-binop (mock real)
 209   "Test a binary set operation."
 210   (loop for s1 in bool-vector-test-vectors
 211         for bv1 = (test-bool-vector-bv-from-hex-string s1)
 212         for vecs2 = (cl-remove-if-not
 213                      (lambda (x) (eql (length x) (length s1)))
 214                      bool-vector-test-vectors)
 215         do (loop for s2 in vecs2
 216                  for bv2 = (test-bool-vector-bv-from-hex-string s2)
 217                  for mock-result = (test-bool-vector-apply-mock-op
 218                                     mock nil bv1 bv2)
 219                  for real-result = (funcall real bv1 bv2)
 220                  do (progn
 221                       (should (equal mock-result real-result))))))
 222
 223 (ert-deftest bool-vector-intersection-op ()
 224   (test-bool-vector-binop
 225    #'logand
 226    #'bool-vector-intersection))
 227
 228 (ert-deftest bool-vector-union-op ()
 229   (test-bool-vector-binop
 230    #'logior
 231    #'bool-vector-union))
 232
 233 (ert-deftest bool-vector-xor-op ()
 234   (test-bool-vector-binop
 235    #'logxor
 236    #'bool-vector-exclusive-or))
 237
 238 (ert-deftest bool-vector-set-difference-op ()
 239   (test-bool-vector-binop
 240    (lambda (a b) (logand a (lognot b)))
 241    #'bool-vector-set-difference))
 242
 243 (ert-deftest bool-vector-change-detection ()
 244   (let* ((vc1 (test-bool-vector-bv-from-hex-string "abcdef"))
 245          (vc2 (test-bool-vector-bv-from-hex-string "012345"))
 246          (vc3 (make-bool-vector (length vc1) nil))
 247          (c1 (bool-vector-union vc1 vc2 vc3))
 248          (c2 (bool-vector-union vc1 vc2 vc3)))
 249     (should (equal c1 (test-bool-vector-apply-mock-op
 250                        #'logior
 251                        nil
 252                        vc1 vc2)))
 253     (should (not c2))))
 254
 255 (ert-deftest bool-vector-not ()
 256   (let* ((v1 (test-bool-vector-bv-from-hex-string "FFFF3"))
 257          (v2 (test-bool-vector-bv-from-hex-string "0000C"))
 258          (v3 (bool-vector-not v1)))
 259     (should (equal v2 v3))))