test/src/data-tests.el

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