test/src/data-tests.el

   1 ;;; data-tests.el --- tests for src/data.c
   2
   3 ;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs.  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 (= most-negative-fixnum (float most-negative-fixnum)))
  33   (should-not (= most-positive-fixnum (+ 1.0 most-positive-fixnum)))
  34   (should-not (apply #'= '(3 8 3)))
  35   (should-error (= 9 9 'foo))
  36   ;; Short circuits before getting to bad arg
  37   (should-not (= 9 8 'foo)))
  38
  39 (ert-deftest data-tests-< ()
  40   (should-error (<))
  41   (should (< 1))
  42   (should (< 2 3))
  43   (should (< -6 -1 0 2 3 4 8 9 999))
  44   (should (< 0.5 most-positive-fixnum (+ 1.0 most-positive-fixnum)))
  45   (should-not (apply #'< '(3 8 3)))
  46   (should-error (< 9 10 'foo))
  47   ;; Short circuits before getting to bad arg
  48   (should-not (< 9 8 'foo)))
  49
  50 (ert-deftest data-tests-> ()
  51   (should-error (>))
  52   (should (> 1))
  53   (should (> 3 2))
  54   (should (> 6 1 0 -2 -3 -4 -8 -9 -999))
  55   (should (> (+ 1.0 most-positive-fixnum) most-positive-fixnum 0.5))
  56   (should-not (apply #'> '(3 8 3)))
  57   (should-error (> 9 8 'foo))
  58   ;; Short circuits before getting to bad arg
  59   (should-not (> 8 9 'foo)))
  60
  61 (ert-deftest data-tests-<= ()
  62   (should-error (<=))
  63   (should (<= 1))
  64   (should (<= 2 3))
  65   (should (<= -6 -1 -1 0 0 0 2 3 4 8 999))
  66   (should (<= 0.5 most-positive-fixnum (+ 1.0 most-positive-fixnum)))
  67   (should-not (apply #'<= '(3 8 3 3)))
  68   (should-error (<= 9 10 'foo))
  69   ;; Short circuits before getting to bad arg
  70   (should-not (<= 9 8 'foo)))
  71
  72 (ert-deftest data-tests->= ()
  73   (should-error (>=))
  74   (should (>= 1))
  75   (should (>= 3 2))
  76   (should (>= 666 1 0 0 -2 -3 -3 -3 -4 -8 -8 -9 -999))
  77   (should (>= (+ 1.0 most-positive-fixnum) most-positive-fixnum))
  78   (should-not (apply #'>= '(3 8 3)))
  79   (should-error (>= 9 8 'foo))
  80   ;; Short circuits before getting to bad arg
  81   (should-not (>= 8 9 'foo)))
  82
  83 ;; Bool vector tests.  Compactly represent bool vectors as hex
  84 ;; strings.
  85
  86 (ert-deftest bool-vector-count-population-all-0-nil ()
  87   (cl-loop for sz in '(0 45 1 64 9 344)
  88            do (let* ((bv (make-bool-vector sz nil)))
  89                 (should
  90                  (zerop
  91                   (bool-vector-count-population bv))))))
  92
  93 (ert-deftest bool-vector-count-population-all-1-t ()
  94   (cl-loop for sz in '(0 45 1 64 9 344)
  95            do (let* ((bv (make-bool-vector sz t)))
  96                 (should
  97                  (eql
  98                   (bool-vector-count-population bv)
  99                   sz)))))
 100
 101 (ert-deftest bool-vector-count-population-1-nil ()
 102   (let* ((bv (make-bool-vector 45 nil)))
 103     (aset bv 40 t)
 104     (aset bv 0 t)
 105     (should
 106      (eql
 107       (bool-vector-count-population bv)
 108       2))))
 109
 110 (ert-deftest bool-vector-count-population-1-t ()
 111   (let* ((bv (make-bool-vector 45 t)))
 112     (aset bv 40 nil)
 113     (aset bv 0 nil)
 114     (should
 115      (eql
 116       (bool-vector-count-population bv)
 117       43))))
 118
 119 (defun mock-bool-vector-count-consecutive (a b i)
 120   (loop for i from i below (length a)
 121         while (eq (aref a i) b)
 122         sum 1))
 123
 124 (defun test-bool-vector-bv-from-hex-string (desc)
 125   (let (bv nchars nibbles)
 126     (dolist (c (string-to-list desc))
 127       (push (string-to-number
 128              (char-to-string c)
 129              16)
 130             nibbles))
 131     (setf bv (make-bool-vector (* 4 (length nibbles)) nil))
 132     (let ((i 0))
 133       (dolist (n (nreverse nibbles))
 134         (dotimes (_ 4)
 135           (aset bv i (> (logand 1 n) 0))
 136           (incf i)
 137           (setf n (lsh n -1)))))
 138     bv))
 139
 140 (defun test-bool-vector-to-hex-string (bv)
 141   (let (nibbles (v (cl-coerce bv 'list)))
 142     (while v
 143       (push (logior
 144              (lsh (if (nth 0 v) 1 0) 0)
 145              (lsh (if (nth 1 v) 1 0) 1)
 146              (lsh (if (nth 2 v) 1 0) 2)
 147              (lsh (if (nth 3 v) 1 0) 3))
 148             nibbles)
 149       (setf v (nthcdr 4 v)))
 150     (mapconcat (lambda (n) (format "%X" n))
 151                (nreverse nibbles)
 152                "")))
 153
 154 (defun test-bool-vector-count-consecutive-tc (desc)
 155   "Run a test case for bool-vector-count-consecutive.
 156 DESC is a string describing the test.  It is a sequence of
 157 hexadecimal digits describing the bool vector.  We exhaustively
 158 test all counts at all possible positions in the vector by
 159 comparing the subr with a much slower lisp implementation."
 160   (let ((bv (test-bool-vector-bv-from-hex-string desc)))
 161     (loop
 162      for lf in '(nil t)
 163      do (loop
 164          for pos from 0 upto (length bv)
 165          for cnt = (mock-bool-vector-count-consecutive bv lf pos)
 166          for rcnt = (bool-vector-count-consecutive bv lf pos)
 167          unless (eql cnt rcnt)
 168          do (error "FAILED testcase %S %3S %3S %3S"
 169                    pos lf cnt rcnt)))))
 170
 171 (defconst bool-vector-test-vectors
 172 '(""
 173   "0"
 174   "F"
 175   "0F"
 176   "F0"
 177   "00000000000000000000000000000FFFFF0000000"
 178   "44a50234053fba3340000023444a50234053fba33400000234"
 179   "12341234123456123412346001234123412345612341234600"
 180   "44a50234053fba33400000234"
 181   "1234123412345612341234600"
 182   "44a50234053fba33400000234"
 183   "1234123412345612341234600"
 184   "44a502340"
 185   "123412341"
 186   "0000000000000000000000000"
 187   "FFFFFFFFFFFFFFFF1"))
 188
 189 (ert-deftest bool-vector-count-consecutive ()
 190   (mapc #'test-bool-vector-count-consecutive-tc
 191         bool-vector-test-vectors))
 192
 193 (defun test-bool-vector-apply-mock-op (mock a b c)
 194   "Compute (slowly) the correct result of a bool-vector set operation."
 195   (let (changed nv)
 196     (assert (eql (length b) (length c)))
 197     (if a (setf nv a)
 198       (setf a (make-bool-vector (length b) nil))
 199       (setf changed t))
 200
 201     (loop for i below (length b)
 202           for mockr = (funcall mock
 203                                (if (aref b i) 1 0)
 204                                (if (aref c i) 1 0))
 205           for r = (not (= 0 mockr))
 206           do (progn
 207                (unless (eq (aref a i) r)
 208                  (setf changed t))
 209                (setf (aref a i) r)))
 210     (if changed a)))
 211
 212 (defun test-bool-vector-binop (mock real)
 213   "Test a binary set operation."
 214   (loop for s1 in bool-vector-test-vectors
 215         for bv1 = (test-bool-vector-bv-from-hex-string s1)
 216         for vecs2 = (cl-remove-if-not
 217                      (lambda (x) (eql (length x) (length s1)))
 218                      bool-vector-test-vectors)
 219         do (loop for s2 in vecs2
 220                  for bv2 = (test-bool-vector-bv-from-hex-string s2)
 221                  for mock-result = (test-bool-vector-apply-mock-op
 222                                     mock nil bv1 bv2)
 223                  for real-result = (funcall real bv1 bv2)
 224                  do (progn
 225                       (should (equal mock-result real-result))))))
 226
 227 (ert-deftest bool-vector-intersection-op ()
 228   (test-bool-vector-binop
 229    #'logand
 230    #'bool-vector-intersection))
 231
 232 (ert-deftest bool-vector-union-op ()
 233   (test-bool-vector-binop
 234    #'logior
 235    #'bool-vector-union))
 236
 237 (ert-deftest bool-vector-xor-op ()
 238   (test-bool-vector-binop
 239    #'logxor
 240    #'bool-vector-exclusive-or))
 241
 242 (ert-deftest bool-vector-set-difference-op ()
 243   (test-bool-vector-binop
 244    (lambda (a b) (logand a (lognot b)))
 245    #'bool-vector-set-difference))
 246
 247 (ert-deftest bool-vector-change-detection ()
 248   (let* ((vc1 (test-bool-vector-bv-from-hex-string "abcdef"))
 249          (vc2 (test-bool-vector-bv-from-hex-string "012345"))
 250          (vc3 (make-bool-vector (length vc1) nil))
 251          (c1 (bool-vector-union vc1 vc2 vc3))
 252          (c2 (bool-vector-union vc1 vc2 vc3)))
 253     (should (equal c1 (test-bool-vector-apply-mock-op
 254                        #'logior
 255                        nil
 256                        vc1 vc2)))
 257     (should (not c2))))
 258
 259 (ert-deftest bool-vector-not ()
 260   (let* ((v1 (test-bool-vector-bv-from-hex-string "FFFF3"))
 261          (v2 (test-bool-vector-bv-from-hex-string "0000C"))
 262          (v3 (bool-vector-not v1)))
 263     (should (equal v2 v3))))
 264
 265 ;; Tests for variable bindings
 266
 267 (defvar binding-test-buffer-A (get-buffer-create "A"))
 268 (defvar binding-test-buffer-B (get-buffer-create "B"))
 269
 270 (defvar binding-test-always-local 'always)
 271 (make-variable-buffer-local 'binding-test-always-local)
 272
 273 (defvar binding-test-some-local 'some)
 274 (with-current-buffer binding-test-buffer-A
 275   (set (make-local-variable 'binding-test-some-local) 'local))
 276
 277 (ert-deftest binding-test-manual ()
 278   "A test case from the elisp manual."
 279   (save-excursion
 280     (set-buffer binding-test-buffer-A)
 281     (let ((binding-test-some-local 'something-else))
 282       (should (eq binding-test-some-local 'something-else))
 283       (set-buffer binding-test-buffer-B)
 284       (should (eq binding-test-some-local 'some)))
 285     (should (eq binding-test-some-local 'some))
 286     (set-buffer binding-test-buffer-A)
 287     (should (eq binding-test-some-local 'local))))
 288
 289 (ert-deftest binding-test-setq-default ()
 290   "Test that a setq-default has no effect when there is a local binding."
 291   (save-excursion
 292     (set-buffer binding-test-buffer-B)
 293     ;; This variable is not local in this buffer.
 294     (let ((binding-test-some-local 'something-else))
 295       (setq-default binding-test-some-local 'new-default))
 296     (should (eq binding-test-some-local 'some))))
 297
 298 (ert-deftest binding-test-makunbound ()
 299   "Tests of makunbound, from the manual."
 300   (save-excursion
 301     (set-buffer binding-test-buffer-B)
 302     (should (boundp 'binding-test-some-local))
 303     (let ((binding-test-some-local 'outer))
 304       (let ((binding-test-some-local 'inner))
 305         (makunbound 'binding-test-some-local)
 306         (should (not (boundp 'binding-test-some-local))))
 307       (should (and (boundp 'binding-test-some-local)
 308                    (eq binding-test-some-local 'outer))))))
 309
 310 (ert-deftest binding-test-defvar-bool ()
 311   "Test DEFVAR_BOOL"
 312   (let ((display-hourglass 5))
 313     (should (eq display-hourglass t))))
 314
 315 (ert-deftest binding-test-defvar-int ()
 316   "Test DEFVAR_INT"
 317   (should-error (setq gc-cons-threshold 5.0) :type 'wrong-type-argument))
 318
 319 (ert-deftest binding-test-set-constant-t ()
 320   "Test setting the constant t"
 321   (should-error (setq t 'bob) :type 'setting-constant))
 322
 323 (ert-deftest binding-test-set-constant-nil ()
 324   "Test setting the constant nil"
 325   (should-error (setq nil 'bob) :type 'setting-constant))
 326
 327 (ert-deftest binding-test-set-constant-keyword ()
 328   "Test setting a keyword constant"
 329   (should-error (setq :keyword 'bob) :type 'setting-constant))
 330
 331 (ert-deftest binding-test-set-constant-nil ()
 332   "Test setting a keyword to itself"
 333   (should (setq :keyword :keyword)))
 334
 335 ;; More tests to write -
 336 ;; kill-local-variable
 337 ;; defconst; can modify
 338 ;; defvar and defconst modify the local binding [ doesn't matter for us ]
 339 ;; various kinds of special internal forwarding objects
 340 ;;   a couple examples in manual, not enough
 341 ;; variable aliases
 342
 343 ;; Tests for watchpoints
 344
 345 (ert-deftest data-tests-variable-watchers ()
 346   (defvar data-tests-var 0)
 347   (let* ((watch-data nil)
 348          (collect-watch-data
 349           (lambda (&rest args) (push args watch-data))))
 350     (cl-flet ((should-have-watch-data (data)
 351                                       (should (equal (pop watch-data) data))
 352                                       (should (null watch-data))))
 353       (add-variable-watcher 'data-tests-var collect-watch-data)
 354       (setq data-tests-var 1)
 355       (should-have-watch-data '(data-tests-var 1 set nil))
 356       (let ((data-tests-var 2))
 357         (should-have-watch-data '(data-tests-var 2 let nil))
 358         (setq data-tests-var 3)
 359         (should-have-watch-data '(data-tests-var 3 set nil)))
 360       (should-have-watch-data '(data-tests-var 1 unlet nil))
 361       ;; `setq-default' on non-local variable is same as `setq'.
 362       (setq-default data-tests-var 4)
 363       (should-have-watch-data '(data-tests-var 4 set nil))
 364       (makunbound 'data-tests-var)
 365       (should-have-watch-data '(data-tests-var nil makunbound nil))
 366       (setq data-tests-var 5)
 367       (should-have-watch-data '(data-tests-var 5 set nil))
 368       (remove-variable-watcher 'data-tests-var collect-watch-data)
 369       (setq data-tests-var 6)
 370       (should (null watch-data)))))
 371
 372 (ert-deftest data-tests-varalias-watchers ()
 373   (defvar data-tests-var0 0)
 374   (defvar data-tests-var1 0)
 375   (defvar data-tests-var2 0)
 376   (defvar data-tests-var3 0)
 377   (let* ((watch-data nil)
 378          (collect-watch-data
 379           (lambda (&rest args) (push args watch-data))))
 380     (cl-flet ((should-have-watch-data (data)
 381                                       (should (equal (pop watch-data) data))
 382                                       (should (null watch-data))))
 383       ;; Watch var0, then alias it.
 384       (add-variable-watcher 'data-tests-var0 collect-watch-data)
 385       (defvaralias 'data-tests-var0-alias 'data-tests-var0)
 386       (setq data-tests-var0 1)
 387       (should-have-watch-data '(data-tests-var0 1 set nil))
 388       (setq data-tests-var0-alias 2)
 389       (should-have-watch-data '(data-tests-var0 2 set nil))
 390       ;; Alias var1, then watch var1-alias.
 391       (defvaralias 'data-tests-var1-alias 'data-tests-var1)
 392       (add-variable-watcher 'data-tests-var1-alias collect-watch-data)
 393       (setq data-tests-var1 1)
 394       (should-have-watch-data '(data-tests-var1 1 set nil))
 395       (setq data-tests-var1-alias 2)
 396       (should-have-watch-data '(data-tests-var1 2 set nil))
 397       ;; Alias var2, then watch it.
 398       (defvaralias 'data-tests-var2-alias 'data-tests-var2)
 399       (add-variable-watcher 'data-tests-var2 collect-watch-data)
 400       (setq data-tests-var2 1)
 401       (should-have-watch-data '(data-tests-var2 1 set nil))
 402       (setq data-tests-var2-alias 2)
 403       (should-have-watch-data '(data-tests-var2 2 set nil))
 404       ;; Watch var3-alias, then make it alias var3 (this removes the
 405       ;; watcher flag).
 406       (defvar data-tests-var3-alias 0)
 407       (add-variable-watcher 'data-tests-var3-alias collect-watch-data)
 408       (defvaralias 'data-tests-var3-alias 'data-tests-var3)
 409       (should-have-watch-data '(data-tests-var3-alias
 410                                 data-tests-var3 defvaralias nil))
 411       (setq data-tests-var3 1)
 412       (setq data-tests-var3-alias 2)
 413       (should (null watch-data)))))
 414
 415 (ert-deftest data-tests-local-variable-watchers ()
 416   (defvar-local data-tests-lvar 0)
 417   (let* ((buf1 (current-buffer))
 418          (buf2 nil)
 419          (watch-data nil)
 420          (collect-watch-data
 421           (lambda (&rest args) (push args watch-data))))
 422     (cl-flet ((should-have-watch-data (data)
 423                                       (should (equal (pop watch-data) data))
 424                                       (should (null watch-data))))
 425       (add-variable-watcher 'data-tests-lvar collect-watch-data)
 426       (setq data-tests-lvar 1)
 427       (should-have-watch-data `(data-tests-lvar 1 set ,buf1))
 428       (let ((data-tests-lvar 2))
 429         (should-have-watch-data `(data-tests-lvar 2 let ,buf1))
 430         (setq data-tests-lvar 3)
 431         (should-have-watch-data `(data-tests-lvar 3 set ,buf1)))
 432       (should-have-watch-data `(data-tests-lvar 1 unlet ,buf1))
 433       (setq-default data-tests-lvar 4)
 434       (should-have-watch-data `(data-tests-lvar 4 set nil))
 435       (with-temp-buffer
 436         (setq buf2 (current-buffer))
 437         (setq data-tests-lvar 1)
 438         (should-have-watch-data `(data-tests-lvar 1 set ,buf2))
 439         (let ((data-tests-lvar 2))
 440           (should-have-watch-data `(data-tests-lvar 2 let ,buf2))
 441           (setq data-tests-lvar 3)
 442           (should-have-watch-data `(data-tests-lvar 3 set ,buf2)))
 443         (should-have-watch-data `(data-tests-lvar 1 unlet ,buf2))
 444         (kill-local-variable 'data-tests-lvar)
 445         (should-have-watch-data `(data-tests-lvar nil makunbound ,buf2))
 446         (setq data-tests-lvar 3.5)
 447         (should-have-watch-data `(data-tests-lvar 3.5 set ,buf2))
 448         (kill-all-local-variables)
 449         (should-have-watch-data `(data-tests-lvar nil makunbound ,buf2)))
 450       (setq-default data-tests-lvar 4)
 451       (should-have-watch-data `(data-tests-lvar 4 set nil))
 452       (makunbound 'data-tests-lvar)
 453       (should-have-watch-data '(data-tests-lvar nil makunbound nil))
 454       (setq data-tests-lvar 5)
 455       (should-have-watch-data `(data-tests-lvar 5 set ,buf1))
 456       (remove-variable-watcher 'data-tests-lvar collect-watch-data)
 457       (setq data-tests-lvar 6)
 458       (should (null watch-data)))))