1 ;;; data-tests.el --- tests for src/data.c
3 ;; Copyright (C) 2013-2018 Free Software Foundation, Inc.
5 ;; This file is part of GNU Emacs.
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.
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.
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/>.
26 (ert-deftest data-tests-
= ()
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
)))
38 (ert-deftest data-tests-
< ()
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
)))
49 (ert-deftest data-tests-
> ()
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
)))
60 (ert-deftest data-tests-
<= ()
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
)))
71 (ert-deftest data-tests-
>= ()
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
)))
82 (ert-deftest data-tests-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))))
94 (ert-deftest data-tests-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))))
110 (defun data-tests-popcnt (byte)
111 "Calculate the Hamming weight of BYTE."
113 (setq byte
(lognot byte
)))
114 (setq byte
(- byte
(logand (lsh byte -
1) #x55555555
)))
115 (setq byte
(+ (logand byte
#x33333333
) (logand (lsh byte -
2) #x33333333
)))
116 (lsh (* (logand (+ byte
(lsh byte -
4)) #x0f0f0f0f
) #x01010101
) -
24))
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))))
125 ;; Bool vector tests. Compactly represent bool vectors as hex
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
)))
133 (bool-vector-count-population bv
))))))
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
)))
140 (bool-vector-count-population bv
)
143 (ert-deftest bool-vector-count-population-1-nil
()
144 (let* ((bv (make-bool-vector 45 nil
)))
149 (bool-vector-count-population bv
)
152 (ert-deftest bool-vector-count-population-1-t
()
153 (let* ((bv (make-bool-vector 45 t
)))
158 (bool-vector-count-population bv
)
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
)
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
173 (setf bv
(make-bool-vector (* 4 (length nibbles
)) nil
))
175 (dolist (n (nreverse nibbles
))
177 (aset bv i
(> (logand 1 n
) 0))
179 (setf n
(lsh n -
1)))))
182 (defun test-bool-vector-to-hex-string (bv)
183 (let (nibbles (v (cl-coerce bv
'list
)))
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))
191 (setf v
(nthcdr 4 v
)))
192 (mapconcat (lambda (n) (format "%X" n
))
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
)))
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"
213 (defconst bool-vector-test-vectors
219 "00000000000000000000000000000FFFFF0000000"
220 "44a50234053fba3340000023444a50234053fba33400000234"
221 "12341234123456123412346001234123412345612341234600"
222 "44a50234053fba33400000234"
223 "1234123412345612341234600"
224 "44a50234053fba33400000234"
225 "1234123412345612341234600"
228 "0000000000000000000000000"
229 "FFFFFFFFFFFFFFFF1"))
231 (ert-deftest bool-vector-count-consecutive
()
232 (mapc #'test-bool-vector-count-consecutive-tc
233 bool-vector-test-vectors
))
235 (defun test-bool-vector-apply-mock-op (mock a b c
)
236 "Compute (slowly) the correct result of a bool-vector set operation."
238 (cl-assert (eql (length b
) (length c
)))
240 (setf a
(make-bool-vector (length b
) nil
))
243 (cl-loop for i below
(length b
)
244 for mockr
= (funcall mock
247 for r
= (not (= 0 mockr
))
249 (unless (eq (aref a i
) r
)
251 (setf (aref a i
) r
)))
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
265 for real-result
= (funcall real bv1 bv2
)
267 (should (equal mock-result real-result
))))))
269 (ert-deftest bool-vector-intersection-op
()
270 (test-bool-vector-binop
272 #'bool-vector-intersection
))
274 (ert-deftest bool-vector-union-op
()
275 (test-bool-vector-binop
277 #'bool-vector-union
))
279 (ert-deftest bool-vector-xor-op
()
280 (test-bool-vector-binop
282 #'bool-vector-exclusive-or
))
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
))
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
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
))))
307 ;; Tests for variable bindings
309 (defvar binding-test-buffer-A
(get-buffer-create "A"))
310 (defvar binding-test-buffer-B
(get-buffer-create "B"))
312 (defvar binding-test-always-local
'always
)
313 (make-variable-buffer-local 'binding-test-always-local
)
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
))
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
))))
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
))))
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
))))))
349 (ert-deftest binding-test-defvar-bool
()
351 (let ((display-hourglass 5))
352 (should (eq display-hourglass t
))))
354 (ert-deftest binding-test-defvar-int
()
356 (should-error (setq gc-cons-threshold
5.0) :type
'wrong-type-argument
))
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
)))
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
)))
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
)))
370 (ert-deftest binding-test-set-constant-nil
()
371 "Test setting a keyword to itself"
372 (with-no-warnings (should (setq :keyword
:keyword
))))
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
382 ;; Tests for watchpoints
384 (ert-deftest data-tests-variable-watchers
()
385 (defvar data-tests-var
0)
386 (let* ((watch-data nil
)
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
)))))
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
)
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
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
)))))
457 (ert-deftest data-tests-local-variable-watchers
()
459 (defvar-local data-tests-lvar
0))
460 (let* ((buf1 (current-buffer))
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
))
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
)))))