1 ;;; data-tests.el --- tests for src/data.c -*- lexical-binding:t -*-
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 ;; Bool vector tests. Compactly represent bool vectors as hex
113 (ert-deftest bool-vector-count-population-all-0-nil
()
114 (cl-loop for sz in
'(0 45 1 64 9 344)
115 do
(let* ((bv (make-bool-vector sz nil
)))
118 (bool-vector-count-population bv
))))))
120 (ert-deftest bool-vector-count-population-all-1-t
()
121 (cl-loop for sz in
'(0 45 1 64 9 344)
122 do
(let* ((bv (make-bool-vector sz t
)))
125 (bool-vector-count-population bv
)
128 (ert-deftest bool-vector-count-population-1-nil
()
129 (let* ((bv (make-bool-vector 45 nil
)))
134 (bool-vector-count-population bv
)
137 (ert-deftest bool-vector-count-population-1-t
()
138 (let* ((bv (make-bool-vector 45 t
)))
143 (bool-vector-count-population bv
)
146 (defun mock-bool-vector-count-consecutive (a b i
)
147 (cl-loop for i from i below
(length a
)
148 while
(eq (aref a i
) b
)
151 (defun test-bool-vector-bv-from-hex-string (desc)
152 (let (bv nchars nibbles
)
153 (dolist (c (string-to-list desc
))
154 (push (string-to-number
158 (setf bv
(make-bool-vector (* 4 (length nibbles
)) nil
))
160 (dolist (n (nreverse nibbles
))
162 (aset bv i
(> (logand 1 n
) 0))
164 (setf n
(lsh n -
1)))))
167 (defun test-bool-vector-to-hex-string (bv)
168 (let (nibbles (v (cl-coerce bv
'list
)))
171 (lsh (if (nth 0 v
) 1 0) 0)
172 (lsh (if (nth 1 v
) 1 0) 1)
173 (lsh (if (nth 2 v
) 1 0) 2)
174 (lsh (if (nth 3 v
) 1 0) 3))
176 (setf v
(nthcdr 4 v
)))
177 (mapconcat (lambda (n) (format "%X" n
))
181 (defun test-bool-vector-count-consecutive-tc (desc)
182 "Run a test case for bool-vector-count-consecutive.
183 DESC is a string describing the test. It is a sequence of
184 hexadecimal digits describing the bool vector. We exhaustively
185 test all counts at all possible positions in the vector by
186 comparing the subr with a much slower lisp implementation."
187 (let ((bv (test-bool-vector-bv-from-hex-string desc
)))
191 for pos from
0 upto
(length bv
)
192 for cnt
= (mock-bool-vector-count-consecutive bv lf pos
)
193 for rcnt
= (bool-vector-count-consecutive bv lf pos
)
194 unless
(eql cnt rcnt
)
195 do
(error "FAILED testcase %S %3S %3S %3S"
198 (defconst bool-vector-test-vectors
204 "00000000000000000000000000000FFFFF0000000"
205 "44a50234053fba3340000023444a50234053fba33400000234"
206 "12341234123456123412346001234123412345612341234600"
207 "44a50234053fba33400000234"
208 "1234123412345612341234600"
209 "44a50234053fba33400000234"
210 "1234123412345612341234600"
213 "0000000000000000000000000"
214 "FFFFFFFFFFFFFFFF1"))
216 (ert-deftest bool-vector-count-consecutive
()
217 (mapc #'test-bool-vector-count-consecutive-tc
218 bool-vector-test-vectors
))
220 (defun test-bool-vector-apply-mock-op (mock a b c
)
221 "Compute (slowly) the correct result of a bool-vector set operation."
223 (cl-assert (eql (length b
) (length c
)))
225 (setf a
(make-bool-vector (length b
) nil
))
228 (cl-loop for i below
(length b
)
229 for mockr
= (funcall mock
232 for r
= (not (= 0 mockr
))
234 (unless (eq (aref a i
) r
)
236 (setf (aref a i
) r
)))
239 (defun test-bool-vector-binop (mock real
)
240 "Test a binary set operation."
241 (cl-loop for s1 in bool-vector-test-vectors
242 for bv1
= (test-bool-vector-bv-from-hex-string s1
)
243 for vecs2
= (cl-remove-if-not
244 (lambda (x) (eql (length x
) (length s1
)))
245 bool-vector-test-vectors
)
246 do
(cl-loop for s2 in vecs2
247 for bv2
= (test-bool-vector-bv-from-hex-string s2
)
248 for mock-result
= (test-bool-vector-apply-mock-op
250 for real-result
= (funcall real bv1 bv2
)
252 (should (equal mock-result real-result
))))))
254 (ert-deftest bool-vector-intersection-op
()
255 (test-bool-vector-binop
257 #'bool-vector-intersection
))
259 (ert-deftest bool-vector-union-op
()
260 (test-bool-vector-binop
262 #'bool-vector-union
))
264 (ert-deftest bool-vector-xor-op
()
265 (test-bool-vector-binop
267 #'bool-vector-exclusive-or
))
269 (ert-deftest bool-vector-set-difference-op
()
270 (test-bool-vector-binop
271 (lambda (a b
) (logand a
(lognot b
)))
272 #'bool-vector-set-difference
))
274 (ert-deftest bool-vector-change-detection
()
275 (let* ((vc1 (test-bool-vector-bv-from-hex-string "abcdef"))
276 (vc2 (test-bool-vector-bv-from-hex-string "012345"))
277 (vc3 (make-bool-vector (length vc1
) nil
))
278 (c1 (bool-vector-union vc1 vc2 vc3
))
279 (c2 (bool-vector-union vc1 vc2 vc3
)))
280 (should (equal c1
(test-bool-vector-apply-mock-op
286 (ert-deftest bool-vector-not
()
287 (let* ((v1 (test-bool-vector-bv-from-hex-string "FFFF3"))
288 (v2 (test-bool-vector-bv-from-hex-string "0000C"))
289 (v3 (bool-vector-not v1
)))
290 (should (equal v2 v3
))))
292 ;; Tests for variable bindings
294 (defvar binding-test-buffer-A
(get-buffer-create "A"))
295 (defvar binding-test-buffer-B
(get-buffer-create "B"))
297 (defvar binding-test-always-local
'always
)
298 (make-variable-buffer-local 'binding-test-always-local
)
300 (defvar binding-test-some-local
'some
)
301 (with-current-buffer binding-test-buffer-A
302 (set (make-local-variable 'binding-test-some-local
) 'local
))
304 (ert-deftest binding-test-manual
()
305 "A test case from the elisp manual."
306 (with-current-buffer binding-test-buffer-A
307 (let ((binding-test-some-local 'something-else
))
308 (should (eq binding-test-some-local
'something-else
))
309 (set-buffer binding-test-buffer-B
)
310 (should (eq binding-test-some-local
'some
)))
311 (should (eq binding-test-some-local
'some
))
312 (set-buffer binding-test-buffer-A
)
313 (should (eq binding-test-some-local
'local
))))
315 (ert-deftest binding-test-setq-default
()
316 "Test that a setq-default has no effect when there is a local binding."
317 (with-current-buffer binding-test-buffer-B
318 ;; This variable is not local in this buffer.
319 (let ((binding-test-some-local 'something-else
))
320 (setq-default binding-test-some-local
'new-default
))
321 (should (eq binding-test-some-local
'some
))))
323 (ert-deftest binding-test-makunbound
()
324 "Tests of makunbound, from the manual."
325 (with-current-buffer binding-test-buffer-B
326 (should (boundp 'binding-test-some-local
))
327 (let ((binding-test-some-local 'outer
))
328 (let ((binding-test-some-local 'inner
))
329 (makunbound 'binding-test-some-local
)
330 (should (not (boundp 'binding-test-some-local
))))
331 (should (and (boundp 'binding-test-some-local
)
332 (eq binding-test-some-local
'outer
))))))
334 (ert-deftest binding-test-defvar-bool
()
336 (let ((display-hourglass 5))
337 (should (eq display-hourglass t
))))
339 (ert-deftest binding-test-defvar-int
()
341 (should-error (setq gc-cons-threshold
5.0) :type
'wrong-type-argument
))
343 (ert-deftest binding-test-set-constant-t
()
344 "Test setting the constant t"
345 (with-no-warnings (should-error (setq t
'bob
) :type
'setting-constant
)))
347 (ert-deftest binding-test-set-constant-nil
()
348 "Test setting the constant nil"
349 (with-no-warnings (should-error (setq nil
'bob
) :type
'setting-constant
)))
351 (ert-deftest binding-test-set-constant-keyword
()
352 "Test setting a keyword constant"
353 (with-no-warnings (should-error (setq :keyword
'bob
) :type
'setting-constant
)))
355 (ert-deftest binding-test-set-constant-nil
()
356 "Test setting a keyword to itself"
357 (with-no-warnings (should (setq :keyword
:keyword
))))
359 ;; More tests to write -
360 ;; kill-local-variable
361 ;; defconst; can modify
362 ;; defvar and defconst modify the local binding [ doesn't matter for us ]
363 ;; various kinds of special internal forwarding objects
364 ;; a couple examples in manual, not enough
367 ;; Tests for watchpoints
369 (ert-deftest data-tests-variable-watchers
()
370 (defvar data-tests-var
0)
371 (let* ((watch-data nil
)
373 (lambda (&rest args
) (push args watch-data
))))
374 (cl-flet ((should-have-watch-data (data)
375 (should (equal (pop watch-data
) data
))
376 (should (null watch-data
))))
377 (add-variable-watcher 'data-tests-var collect-watch-data
)
378 (setq data-tests-var
1)
379 (should-have-watch-data '(data-tests-var 1 set nil
))
380 (let ((data-tests-var 2))
381 (should-have-watch-data '(data-tests-var 2 let nil
))
382 (setq data-tests-var
3)
383 (should-have-watch-data '(data-tests-var 3 set nil
)))
384 (should-have-watch-data '(data-tests-var 1 unlet nil
))
385 ;; `setq-default' on non-local variable is same as `setq'.
386 (setq-default data-tests-var
4)
387 (should-have-watch-data '(data-tests-var 4 set nil
))
388 (makunbound 'data-tests-var
)
389 (should-have-watch-data '(data-tests-var nil makunbound nil
))
390 (setq data-tests-var
5)
391 (should-have-watch-data '(data-tests-var 5 set nil
))
392 (remove-variable-watcher 'data-tests-var collect-watch-data
)
393 (setq data-tests-var
6)
394 (should (null watch-data
)))))
396 (ert-deftest data-tests-varalias-watchers
()
397 (defvar data-tests-var0
0)
398 (defvar data-tests-var1
0)
399 (defvar data-tests-var2
0)
400 (defvar data-tests-var3
0)
401 (let* ((watch-data nil
)
403 (lambda (&rest args
) (push args watch-data
))))
404 (cl-flet ((should-have-watch-data (data)
405 (should (equal (pop watch-data
) data
))
406 (should (null watch-data
))))
407 ;; Watch var0, then alias it.
408 (add-variable-watcher 'data-tests-var0 collect-watch-data
)
409 (defvar data-tests-var0-alias
)
410 (defvaralias 'data-tests-var0-alias
'data-tests-var0
)
411 (setq data-tests-var0
1)
412 (should-have-watch-data '(data-tests-var0 1 set nil
))
413 (setq data-tests-var0-alias
2)
414 (should-have-watch-data '(data-tests-var0 2 set nil
))
415 ;; Alias var1, then watch var1-alias.
416 (defvar data-tests-var1-alias
)
417 (defvaralias 'data-tests-var1-alias
'data-tests-var1
)
418 (add-variable-watcher 'data-tests-var1-alias collect-watch-data
)
419 (setq data-tests-var1
1)
420 (should-have-watch-data '(data-tests-var1 1 set nil
))
421 (setq data-tests-var1-alias
2)
422 (should-have-watch-data '(data-tests-var1 2 set nil
))
423 ;; Alias var2, then watch it.
424 (defvar data-tests-var2-alias
)
425 (defvaralias 'data-tests-var2-alias
'data-tests-var2
)
426 (add-variable-watcher 'data-tests-var2 collect-watch-data
)
427 (setq data-tests-var2
1)
428 (should-have-watch-data '(data-tests-var2 1 set nil
))
429 (setq data-tests-var2-alias
2)
430 (should-have-watch-data '(data-tests-var2 2 set nil
))
431 ;; Watch var3-alias, then make it alias var3 (this removes the
433 (defvar data-tests-var3-alias
0)
434 (add-variable-watcher 'data-tests-var3-alias collect-watch-data
)
435 (defvaralias 'data-tests-var3-alias
'data-tests-var3
)
436 (should-have-watch-data '(data-tests-var3-alias
437 data-tests-var3 defvaralias nil
))
438 (setq data-tests-var3
1)
439 (setq data-tests-var3-alias
2)
440 (should (null watch-data
)))))
442 (ert-deftest data-tests-local-variable-watchers
()
444 (defvar-local data-tests-lvar
0))
445 (let* ((buf1 (current-buffer))
449 (lambda (&rest args
) (push args watch-data
))))
450 (cl-flet ((should-have-watch-data (data)
451 (should (equal (pop watch-data
) data
))
452 (should (null watch-data
))))
453 (add-variable-watcher 'data-tests-lvar collect-watch-data
)
454 (setq data-tests-lvar
1)
455 (should-have-watch-data `(data-tests-lvar 1 set
,buf1
))
456 (let ((data-tests-lvar 2))
457 (should-have-watch-data `(data-tests-lvar 2 let
,buf1
))
458 (setq data-tests-lvar
3)
459 (should-have-watch-data `(data-tests-lvar 3 set
,buf1
)))
460 (should-have-watch-data `(data-tests-lvar 1 unlet
,buf1
))
461 (setq-default data-tests-lvar
4)
462 (should-have-watch-data `(data-tests-lvar 4 set nil
))
464 (setq buf2
(current-buffer))
465 (setq data-tests-lvar
1)
466 (should-have-watch-data `(data-tests-lvar 1 set
,buf2
))
467 (let ((data-tests-lvar 2))
468 (should-have-watch-data `(data-tests-lvar 2 let
,buf2
))
469 (setq data-tests-lvar
3)
470 (should-have-watch-data `(data-tests-lvar 3 set
,buf2
)))
471 (should-have-watch-data `(data-tests-lvar 1 unlet
,buf2
))
472 (kill-local-variable 'data-tests-lvar
)
473 (should-have-watch-data `(data-tests-lvar nil makunbound
,buf2
))
474 (setq data-tests-lvar
3.5)
475 (should-have-watch-data `(data-tests-lvar 3.5 set
,buf2
))
476 (kill-all-local-variables)
477 (should-have-watch-data `(data-tests-lvar nil makunbound
,buf2
)))
478 (setq-default data-tests-lvar
4)
479 (should-have-watch-data `(data-tests-lvar 4 set nil
))
480 (makunbound 'data-tests-lvar
)
481 (should-have-watch-data '(data-tests-lvar nil makunbound nil
))
482 (setq data-tests-lvar
5)
483 (should-have-watch-data `(data-tests-lvar 5 set
,buf1
))
484 (remove-variable-watcher 'data-tests-lvar collect-watch-data
)
485 (setq data-tests-lvar
6)
486 (should (null watch-data
)))))
488 (ert-deftest data-tests-kill-all-local-variables
() ;bug#30846
490 (setq-local data-tests-foo1
1)
491 (setq-local data-tests-foo2
2)
492 (setq-local data-tests-foo3
3)
494 (add-variable-watcher 'data-tests-foo2
496 (setq oldfoo2
(bound-and-true-p data-tests-foo2
))))
497 (kill-all-local-variables)
498 (should (equal oldfoo2
'2)) ;Watcher is run before changing the var.
499 (should (not (or (bound-and-true-p data-tests-foo1
)
500 (bound-and-true-p data-tests-foo2
)
501 (bound-and-true-p data-tests-foo3
)))))))
503 ;;; data-tests.el ends here