1 ;;; data-tests.el --- tests for src/data.c
3 ;; Copyright (C) 2013-2017 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 <http://www.gnu.org/licenses/>.
25 (eval-when-compile (require 'cl
))
27 (ert-deftest data-tests-
= ()
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
)))
37 (ert-deftest data-tests-
< ()
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
)))
47 (ert-deftest data-tests-
> ()
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
)))
57 (ert-deftest data-tests-
<= ()
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
)))
67 (ert-deftest data-tests-
>= ()
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
)))
77 ;; Bool vector tests. Compactly represent bool vectors as hex
80 (ert-deftest bool-vector-count-population-all-0-nil
()
81 (cl-loop for sz in
'(0 45 1 64 9 344)
82 do
(let* ((bv (make-bool-vector sz nil
)))
85 (bool-vector-count-population bv
))))))
87 (ert-deftest bool-vector-count-population-all-1-t
()
88 (cl-loop for sz in
'(0 45 1 64 9 344)
89 do
(let* ((bv (make-bool-vector sz t
)))
92 (bool-vector-count-population bv
)
95 (ert-deftest bool-vector-count-population-1-nil
()
96 (let* ((bv (make-bool-vector 45 nil
)))
101 (bool-vector-count-population bv
)
104 (ert-deftest bool-vector-count-population-1-t
()
105 (let* ((bv (make-bool-vector 45 t
)))
110 (bool-vector-count-population bv
)
113 (defun mock-bool-vector-count-consecutive (a b i
)
114 (loop for i from i below
(length a
)
115 while
(eq (aref a i
) b
)
118 (defun test-bool-vector-bv-from-hex-string (desc)
119 (let (bv nchars nibbles
)
120 (dolist (c (string-to-list desc
))
121 (push (string-to-number
125 (setf bv
(make-bool-vector (* 4 (length nibbles
)) nil
))
127 (dolist (n (nreverse nibbles
))
129 (aset bv i
(> (logand 1 n
) 0))
131 (setf n
(lsh n -
1)))))
134 (defun test-bool-vector-to-hex-string (bv)
135 (let (nibbles (v (cl-coerce bv
'list
)))
138 (lsh (if (nth 0 v
) 1 0) 0)
139 (lsh (if (nth 1 v
) 1 0) 1)
140 (lsh (if (nth 2 v
) 1 0) 2)
141 (lsh (if (nth 3 v
) 1 0) 3))
143 (setf v
(nthcdr 4 v
)))
144 (mapconcat (lambda (n) (format "%X" n
))
148 (defun test-bool-vector-count-consecutive-tc (desc)
149 "Run a test case for bool-vector-count-consecutive.
150 DESC is a string describing the test. It is a sequence of
151 hexadecimal digits describing the bool vector. We exhaustively
152 test all counts at all possible positions in the vector by
153 comparing the subr with a much slower lisp implementation."
154 (let ((bv (test-bool-vector-bv-from-hex-string desc
)))
158 for pos from
0 upto
(length bv
)
159 for cnt
= (mock-bool-vector-count-consecutive bv lf pos
)
160 for rcnt
= (bool-vector-count-consecutive bv lf pos
)
161 unless
(eql cnt rcnt
)
162 do
(error "FAILED testcase %S %3S %3S %3S"
165 (defconst bool-vector-test-vectors
171 "00000000000000000000000000000FFFFF0000000"
172 "44a50234053fba3340000023444a50234053fba33400000234"
173 "12341234123456123412346001234123412345612341234600"
174 "44a50234053fba33400000234"
175 "1234123412345612341234600"
176 "44a50234053fba33400000234"
177 "1234123412345612341234600"
180 "0000000000000000000000000"
181 "FFFFFFFFFFFFFFFF1"))
183 (ert-deftest bool-vector-count-consecutive
()
184 (mapc #'test-bool-vector-count-consecutive-tc
185 bool-vector-test-vectors
))
187 (defun test-bool-vector-apply-mock-op (mock a b c
)
188 "Compute (slowly) the correct result of a bool-vector set operation."
190 (assert (eql (length b
) (length c
)))
192 (setf a
(make-bool-vector (length b
) nil
))
195 (loop for i below
(length b
)
196 for mockr
= (funcall mock
199 for r
= (not (= 0 mockr
))
201 (unless (eq (aref a i
) r
)
203 (setf (aref a i
) r
)))
206 (defun test-bool-vector-binop (mock real
)
207 "Test a binary set operation."
208 (loop for s1 in bool-vector-test-vectors
209 for bv1
= (test-bool-vector-bv-from-hex-string s1
)
210 for vecs2
= (cl-remove-if-not
211 (lambda (x) (eql (length x
) (length s1
)))
212 bool-vector-test-vectors
)
213 do
(loop for s2 in vecs2
214 for bv2
= (test-bool-vector-bv-from-hex-string s2
)
215 for mock-result
= (test-bool-vector-apply-mock-op
217 for real-result
= (funcall real bv1 bv2
)
219 (should (equal mock-result real-result
))))))
221 (ert-deftest bool-vector-intersection-op
()
222 (test-bool-vector-binop
224 #'bool-vector-intersection
))
226 (ert-deftest bool-vector-union-op
()
227 (test-bool-vector-binop
229 #'bool-vector-union
))
231 (ert-deftest bool-vector-xor-op
()
232 (test-bool-vector-binop
234 #'bool-vector-exclusive-or
))
236 (ert-deftest bool-vector-set-difference-op
()
237 (test-bool-vector-binop
238 (lambda (a b
) (logand a
(lognot b
)))
239 #'bool-vector-set-difference
))
241 (ert-deftest bool-vector-change-detection
()
242 (let* ((vc1 (test-bool-vector-bv-from-hex-string "abcdef"))
243 (vc2 (test-bool-vector-bv-from-hex-string "012345"))
244 (vc3 (make-bool-vector (length vc1
) nil
))
245 (c1 (bool-vector-union vc1 vc2 vc3
))
246 (c2 (bool-vector-union vc1 vc2 vc3
)))
247 (should (equal c1
(test-bool-vector-apply-mock-op
253 (ert-deftest bool-vector-not
()
254 (let* ((v1 (test-bool-vector-bv-from-hex-string "FFFF3"))
255 (v2 (test-bool-vector-bv-from-hex-string "0000C"))
256 (v3 (bool-vector-not v1
)))
257 (should (equal v2 v3
))))
259 ;; Tests for variable bindings
261 (defvar binding-test-buffer-A
(get-buffer-create "A"))
262 (defvar binding-test-buffer-B
(get-buffer-create "B"))
264 (defvar binding-test-always-local
'always
)
265 (make-variable-buffer-local 'binding-test-always-local
)
267 (defvar binding-test-some-local
'some
)
268 (with-current-buffer binding-test-buffer-A
269 (set (make-local-variable 'binding-test-some-local
) 'local
))
271 (ert-deftest binding-test-manual
()
272 "A test case from the elisp manual."
274 (set-buffer binding-test-buffer-A
)
275 (let ((binding-test-some-local 'something-else
))
276 (should (eq binding-test-some-local
'something-else
))
277 (set-buffer binding-test-buffer-B
)
278 (should (eq binding-test-some-local
'some
)))
279 (should (eq binding-test-some-local
'some
))
280 (set-buffer binding-test-buffer-A
)
281 (should (eq binding-test-some-local
'local
))))
283 (ert-deftest binding-test-setq-default
()
284 "Test that a setq-default has no effect when there is a local binding."
286 (set-buffer binding-test-buffer-B
)
287 ;; This variable is not local in this buffer.
288 (let ((binding-test-some-local 'something-else
))
289 (setq-default binding-test-some-local
'new-default
))
290 (should (eq binding-test-some-local
'some
))))
292 (ert-deftest binding-test-makunbound
()
293 "Tests of makunbound, from the manual."
295 (set-buffer binding-test-buffer-B
)
296 (should (boundp 'binding-test-some-local
))
297 (let ((binding-test-some-local 'outer
))
298 (let ((binding-test-some-local 'inner
))
299 (makunbound 'binding-test-some-local
)
300 (should (not (boundp 'binding-test-some-local
))))
301 (should (and (boundp 'binding-test-some-local
)
302 (eq binding-test-some-local
'outer
))))))
304 (ert-deftest binding-test-defvar-bool
()
306 (let ((display-hourglass 5))
307 (should (eq display-hourglass t
))))
309 (ert-deftest binding-test-defvar-int
()
311 (should-error (setq gc-cons-threshold
5.0) :type
'wrong-type-argument
))
313 (ert-deftest binding-test-set-constant-t
()
314 "Test setting the constant t"
315 (should-error (setq t
'bob
) :type
'setting-constant
))
317 (ert-deftest binding-test-set-constant-nil
()
318 "Test setting the constant nil"
319 (should-error (setq nil
'bob
) :type
'setting-constant
))
321 (ert-deftest binding-test-set-constant-keyword
()
322 "Test setting a keyword constant"
323 (should-error (setq :keyword
'bob
) :type
'setting-constant
))
325 (ert-deftest binding-test-set-constant-nil
()
326 "Test setting a keyword to itself"
327 (should (setq :keyword
:keyword
)))
329 ;; More tests to write -
330 ;; kill-local-variable
331 ;; defconst; can modify
332 ;; defvar and defconst modify the local binding [ doesn't matter for us ]
333 ;; various kinds of special internal forwarding objects
334 ;; a couple examples in manual, not enough
337 ;; Tests for watchpoints
339 (ert-deftest data-tests-variable-watchers
()
340 (defvar data-tests-var
0)
341 (let* ((watch-data nil
)
343 (lambda (&rest args
) (push args watch-data
))))
344 (cl-flet ((should-have-watch-data (data)
345 (should (equal (pop watch-data
) data
))
346 (should (null watch-data
))))
347 (add-variable-watcher 'data-tests-var collect-watch-data
)
348 (setq data-tests-var
1)
349 (should-have-watch-data '(data-tests-var 1 set nil
))
350 (let ((data-tests-var 2))
351 (should-have-watch-data '(data-tests-var 2 let nil
))
352 (setq data-tests-var
3)
353 (should-have-watch-data '(data-tests-var 3 set nil
)))
354 (should-have-watch-data '(data-tests-var 1 unlet nil
))
355 ;; `setq-default' on non-local variable is same as `setq'.
356 (setq-default data-tests-var
4)
357 (should-have-watch-data '(data-tests-var 4 set nil
))
358 (makunbound 'data-tests-var
)
359 (should-have-watch-data '(data-tests-var nil makunbound nil
))
360 (setq data-tests-var
5)
361 (should-have-watch-data '(data-tests-var 5 set nil
))
362 (remove-variable-watcher 'data-tests-var collect-watch-data
)
363 (setq data-tests-var
6)
364 (should (null watch-data
)))))
366 (ert-deftest data-tests-varalias-watchers
()
367 (defvar data-tests-var0
0)
368 (defvar data-tests-var1
0)
369 (defvar data-tests-var2
0)
370 (defvar data-tests-var3
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 ;; Watch var0, then alias it.
378 (add-variable-watcher 'data-tests-var0 collect-watch-data
)
379 (defvaralias 'data-tests-var0-alias
'data-tests-var0
)
380 (setq data-tests-var0
1)
381 (should-have-watch-data '(data-tests-var0 1 set nil
))
382 (setq data-tests-var0-alias
2)
383 (should-have-watch-data '(data-tests-var0 2 set nil
))
384 ;; Alias var1, then watch var1-alias.
385 (defvaralias 'data-tests-var1-alias
'data-tests-var1
)
386 (add-variable-watcher 'data-tests-var1-alias collect-watch-data
)
387 (setq data-tests-var1
1)
388 (should-have-watch-data '(data-tests-var1 1 set nil
))
389 (setq data-tests-var1-alias
2)
390 (should-have-watch-data '(data-tests-var1 2 set nil
))
391 ;; Alias var2, then watch it.
392 (defvaralias 'data-tests-var2-alias
'data-tests-var2
)
393 (add-variable-watcher 'data-tests-var2 collect-watch-data
)
394 (setq data-tests-var2
1)
395 (should-have-watch-data '(data-tests-var2 1 set nil
))
396 (setq data-tests-var2-alias
2)
397 (should-have-watch-data '(data-tests-var2 2 set nil
))
398 ;; Watch var3-alias, then make it alias var3 (this removes the
400 (defvar data-tests-var3-alias
0)
401 (add-variable-watcher 'data-tests-var3-alias collect-watch-data
)
402 (defvaralias 'data-tests-var3-alias
'data-tests-var3
)
403 (should-have-watch-data '(data-tests-var3-alias
404 data-tests-var3 defvaralias nil
))
405 (setq data-tests-var3
1)
406 (setq data-tests-var3-alias
2)
407 (should (null watch-data
)))))
409 (ert-deftest data-tests-local-variable-watchers
()
410 (defvar-local data-tests-lvar
0)
411 (let* ((buf1 (current-buffer))
415 (lambda (&rest args
) (push args watch-data
))))
416 (cl-flet ((should-have-watch-data (data)
417 (should (equal (pop watch-data
) data
))
418 (should (null watch-data
))))
419 (add-variable-watcher 'data-tests-lvar collect-watch-data
)
420 (setq data-tests-lvar
1)
421 (should-have-watch-data `(data-tests-lvar 1 set
,buf1
))
422 (let ((data-tests-lvar 2))
423 (should-have-watch-data `(data-tests-lvar 2 let
,buf1
))
424 (setq data-tests-lvar
3)
425 (should-have-watch-data `(data-tests-lvar 3 set
,buf1
)))
426 (should-have-watch-data `(data-tests-lvar 1 unlet
,buf1
))
427 (setq-default data-tests-lvar
4)
428 (should-have-watch-data `(data-tests-lvar 4 set nil
))
430 (setq buf2
(current-buffer))
431 (setq data-tests-lvar
1)
432 (should-have-watch-data `(data-tests-lvar 1 set
,buf2
))
433 (let ((data-tests-lvar 2))
434 (should-have-watch-data `(data-tests-lvar 2 let
,buf2
))
435 (setq data-tests-lvar
3)
436 (should-have-watch-data `(data-tests-lvar 3 set
,buf2
)))
437 (should-have-watch-data `(data-tests-lvar 1 unlet
,buf2
))
438 (kill-local-variable 'data-tests-lvar
)
439 (should-have-watch-data `(data-tests-lvar nil makunbound
,buf2
))
440 (setq data-tests-lvar
3.5)
441 (should-have-watch-data `(data-tests-lvar 3.5 set
,buf2
))
442 (kill-all-local-variables)
443 (should-have-watch-data `(data-tests-lvar nil makunbound
,buf2
)))
444 (setq-default data-tests-lvar
4)
445 (should-have-watch-data `(data-tests-lvar 4 set nil
))
446 (makunbound 'data-tests-lvar
)
447 (should-have-watch-data '(data-tests-lvar nil makunbound nil
))
448 (setq data-tests-lvar
5)
449 (should-have-watch-data `(data-tests-lvar 5 set
,buf1
))
450 (remove-variable-watcher 'data-tests-lvar collect-watch-data
)
451 (setq data-tests-lvar
6)
452 (should (null watch-data
)))))