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/>.
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))))
106 ;; Bool vector tests. Compactly represent bool vectors as hex
109 (ert-deftest bool-vector-count-population-all-0-nil
()
110 (cl-loop for sz in
'(0 45 1 64 9 344)
111 do
(let* ((bv (make-bool-vector sz nil
)))
114 (bool-vector-count-population bv
))))))
116 (ert-deftest bool-vector-count-population-all-1-t
()
117 (cl-loop for sz in
'(0 45 1 64 9 344)
118 do
(let* ((bv (make-bool-vector sz t
)))
121 (bool-vector-count-population bv
)
124 (ert-deftest bool-vector-count-population-1-nil
()
125 (let* ((bv (make-bool-vector 45 nil
)))
130 (bool-vector-count-population bv
)
133 (ert-deftest bool-vector-count-population-1-t
()
134 (let* ((bv (make-bool-vector 45 t
)))
139 (bool-vector-count-population bv
)
142 (defun mock-bool-vector-count-consecutive (a b i
)
143 (cl-loop for i from i below
(length a
)
144 while
(eq (aref a i
) b
)
147 (defun test-bool-vector-bv-from-hex-string (desc)
148 (let (bv nchars nibbles
)
149 (dolist (c (string-to-list desc
))
150 (push (string-to-number
154 (setf bv
(make-bool-vector (* 4 (length nibbles
)) nil
))
156 (dolist (n (nreverse nibbles
))
158 (aset bv i
(> (logand 1 n
) 0))
160 (setf n
(lsh n -
1)))))
163 (defun test-bool-vector-to-hex-string (bv)
164 (let (nibbles (v (cl-coerce bv
'list
)))
167 (lsh (if (nth 0 v
) 1 0) 0)
168 (lsh (if (nth 1 v
) 1 0) 1)
169 (lsh (if (nth 2 v
) 1 0) 2)
170 (lsh (if (nth 3 v
) 1 0) 3))
172 (setf v
(nthcdr 4 v
)))
173 (mapconcat (lambda (n) (format "%X" n
))
177 (defun test-bool-vector-count-consecutive-tc (desc)
178 "Run a test case for bool-vector-count-consecutive.
179 DESC is a string describing the test. It is a sequence of
180 hexadecimal digits describing the bool vector. We exhaustively
181 test all counts at all possible positions in the vector by
182 comparing the subr with a much slower lisp implementation."
183 (let ((bv (test-bool-vector-bv-from-hex-string desc
)))
187 for pos from
0 upto
(length bv
)
188 for cnt
= (mock-bool-vector-count-consecutive bv lf pos
)
189 for rcnt
= (bool-vector-count-consecutive bv lf pos
)
190 unless
(eql cnt rcnt
)
191 do
(error "FAILED testcase %S %3S %3S %3S"
194 (defconst bool-vector-test-vectors
200 "00000000000000000000000000000FFFFF0000000"
201 "44a50234053fba3340000023444a50234053fba33400000234"
202 "12341234123456123412346001234123412345612341234600"
203 "44a50234053fba33400000234"
204 "1234123412345612341234600"
205 "44a50234053fba33400000234"
206 "1234123412345612341234600"
209 "0000000000000000000000000"
210 "FFFFFFFFFFFFFFFF1"))
212 (ert-deftest bool-vector-count-consecutive
()
213 (mapc #'test-bool-vector-count-consecutive-tc
214 bool-vector-test-vectors
))
216 (defun test-bool-vector-apply-mock-op (mock a b c
)
217 "Compute (slowly) the correct result of a bool-vector set operation."
219 (cl-assert (eql (length b
) (length c
)))
221 (setf a
(make-bool-vector (length b
) nil
))
224 (cl-loop for i below
(length b
)
225 for mockr
= (funcall mock
228 for r
= (not (= 0 mockr
))
230 (unless (eq (aref a i
) r
)
232 (setf (aref a i
) r
)))
235 (defun test-bool-vector-binop (mock real
)
236 "Test a binary set operation."
237 (cl-loop for s1 in bool-vector-test-vectors
238 for bv1
= (test-bool-vector-bv-from-hex-string s1
)
239 for vecs2
= (cl-remove-if-not
240 (lambda (x) (eql (length x
) (length s1
)))
241 bool-vector-test-vectors
)
242 do
(cl-loop for s2 in vecs2
243 for bv2
= (test-bool-vector-bv-from-hex-string s2
)
244 for mock-result
= (test-bool-vector-apply-mock-op
246 for real-result
= (funcall real bv1 bv2
)
248 (should (equal mock-result real-result
))))))
250 (ert-deftest bool-vector-intersection-op
()
251 (test-bool-vector-binop
253 #'bool-vector-intersection
))
255 (ert-deftest bool-vector-union-op
()
256 (test-bool-vector-binop
258 #'bool-vector-union
))
260 (ert-deftest bool-vector-xor-op
()
261 (test-bool-vector-binop
263 #'bool-vector-exclusive-or
))
265 (ert-deftest bool-vector-set-difference-op
()
266 (test-bool-vector-binop
267 (lambda (a b
) (logand a
(lognot b
)))
268 #'bool-vector-set-difference
))
270 (ert-deftest bool-vector-change-detection
()
271 (let* ((vc1 (test-bool-vector-bv-from-hex-string "abcdef"))
272 (vc2 (test-bool-vector-bv-from-hex-string "012345"))
273 (vc3 (make-bool-vector (length vc1
) nil
))
274 (c1 (bool-vector-union vc1 vc2 vc3
))
275 (c2 (bool-vector-union vc1 vc2 vc3
)))
276 (should (equal c1
(test-bool-vector-apply-mock-op
282 (ert-deftest bool-vector-not
()
283 (let* ((v1 (test-bool-vector-bv-from-hex-string "FFFF3"))
284 (v2 (test-bool-vector-bv-from-hex-string "0000C"))
285 (v3 (bool-vector-not v1
)))
286 (should (equal v2 v3
))))
288 ;; Tests for variable bindings
290 (defvar binding-test-buffer-A
(get-buffer-create "A"))
291 (defvar binding-test-buffer-B
(get-buffer-create "B"))
293 (defvar binding-test-always-local
'always
)
294 (make-variable-buffer-local 'binding-test-always-local
)
296 (defvar binding-test-some-local
'some
)
297 (with-current-buffer binding-test-buffer-A
298 (set (make-local-variable 'binding-test-some-local
) 'local
))
300 (ert-deftest binding-test-manual
()
301 "A test case from the elisp manual."
302 (with-current-buffer binding-test-buffer-A
303 (let ((binding-test-some-local 'something-else
))
304 (should (eq binding-test-some-local
'something-else
))
305 (set-buffer binding-test-buffer-B
)
306 (should (eq binding-test-some-local
'some
)))
307 (should (eq binding-test-some-local
'some
))
308 (set-buffer binding-test-buffer-A
)
309 (should (eq binding-test-some-local
'local
))))
311 (ert-deftest binding-test-setq-default
()
312 "Test that a setq-default has no effect when there is a local binding."
313 (with-current-buffer binding-test-buffer-B
314 ;; This variable is not local in this buffer.
315 (let ((binding-test-some-local 'something-else
))
316 (setq-default binding-test-some-local
'new-default
))
317 (should (eq binding-test-some-local
'some
))))
319 (ert-deftest binding-test-makunbound
()
320 "Tests of makunbound, from the manual."
321 (with-current-buffer binding-test-buffer-B
322 (should (boundp 'binding-test-some-local
))
323 (let ((binding-test-some-local 'outer
))
324 (let ((binding-test-some-local 'inner
))
325 (makunbound 'binding-test-some-local
)
326 (should (not (boundp 'binding-test-some-local
))))
327 (should (and (boundp 'binding-test-some-local
)
328 (eq binding-test-some-local
'outer
))))))
330 (ert-deftest binding-test-defvar-bool
()
332 (let ((display-hourglass 5))
333 (should (eq display-hourglass t
))))
335 (ert-deftest binding-test-defvar-int
()
337 (should-error (setq gc-cons-threshold
5.0) :type
'wrong-type-argument
))
339 (ert-deftest binding-test-set-constant-t
()
340 "Test setting the constant t"
341 (should-error (setq t
'bob
) :type
'setting-constant
))
343 (ert-deftest binding-test-set-constant-nil
()
344 "Test setting the constant nil"
345 (should-error (setq nil
'bob
) :type
'setting-constant
))
347 (ert-deftest binding-test-set-constant-keyword
()
348 "Test setting a keyword constant"
349 (should-error (setq :keyword
'bob
) :type
'setting-constant
))
351 (ert-deftest binding-test-set-constant-nil
()
352 "Test setting a keyword to itself"
353 (should (setq :keyword
:keyword
)))
355 ;; More tests to write -
356 ;; kill-local-variable
357 ;; defconst; can modify
358 ;; defvar and defconst modify the local binding [ doesn't matter for us ]
359 ;; various kinds of special internal forwarding objects
360 ;; a couple examples in manual, not enough
363 ;; Tests for watchpoints
365 (ert-deftest data-tests-variable-watchers
()
366 (defvar data-tests-var
0)
367 (let* ((watch-data nil
)
369 (lambda (&rest args
) (push args watch-data
))))
370 (cl-flet ((should-have-watch-data (data)
371 (should (equal (pop watch-data
) data
))
372 (should (null watch-data
))))
373 (add-variable-watcher 'data-tests-var collect-watch-data
)
374 (setq data-tests-var
1)
375 (should-have-watch-data '(data-tests-var 1 set nil
))
376 (let ((data-tests-var 2))
377 (should-have-watch-data '(data-tests-var 2 let nil
))
378 (setq data-tests-var
3)
379 (should-have-watch-data '(data-tests-var 3 set nil
)))
380 (should-have-watch-data '(data-tests-var 1 unlet nil
))
381 ;; `setq-default' on non-local variable is same as `setq'.
382 (setq-default data-tests-var
4)
383 (should-have-watch-data '(data-tests-var 4 set nil
))
384 (makunbound 'data-tests-var
)
385 (should-have-watch-data '(data-tests-var nil makunbound nil
))
386 (setq data-tests-var
5)
387 (should-have-watch-data '(data-tests-var 5 set nil
))
388 (remove-variable-watcher 'data-tests-var collect-watch-data
)
389 (setq data-tests-var
6)
390 (should (null watch-data
)))))
392 (ert-deftest data-tests-varalias-watchers
()
393 (defvar data-tests-var0
0)
394 (defvar data-tests-var1
0)
395 (defvar data-tests-var2
0)
396 (defvar data-tests-var3
0)
397 (let* ((watch-data nil
)
399 (lambda (&rest args
) (push args watch-data
))))
400 (cl-flet ((should-have-watch-data (data)
401 (should (equal (pop watch-data
) data
))
402 (should (null watch-data
))))
403 ;; Watch var0, then alias it.
404 (add-variable-watcher 'data-tests-var0 collect-watch-data
)
405 (defvar data-tests-var0-alias
)
406 (defvaralias 'data-tests-var0-alias
'data-tests-var0
)
407 (setq data-tests-var0
1)
408 (should-have-watch-data '(data-tests-var0 1 set nil
))
409 (setq data-tests-var0-alias
2)
410 (should-have-watch-data '(data-tests-var0 2 set nil
))
411 ;; Alias var1, then watch var1-alias.
412 (defvar data-tests-var1-alias
)
413 (defvaralias 'data-tests-var1-alias
'data-tests-var1
)
414 (add-variable-watcher 'data-tests-var1-alias collect-watch-data
)
415 (setq data-tests-var1
1)
416 (should-have-watch-data '(data-tests-var1 1 set nil
))
417 (setq data-tests-var1-alias
2)
418 (should-have-watch-data '(data-tests-var1 2 set nil
))
419 ;; Alias var2, then watch it.
420 (defvar data-tests-var2-alias
)
421 (defvaralias 'data-tests-var2-alias
'data-tests-var2
)
422 (add-variable-watcher 'data-tests-var2 collect-watch-data
)
423 (setq data-tests-var2
1)
424 (should-have-watch-data '(data-tests-var2 1 set nil
))
425 (setq data-tests-var2-alias
2)
426 (should-have-watch-data '(data-tests-var2 2 set nil
))
427 ;; Watch var3-alias, then make it alias var3 (this removes the
429 (defvar data-tests-var3-alias
0)
430 (add-variable-watcher 'data-tests-var3-alias collect-watch-data
)
431 (defvaralias 'data-tests-var3-alias
'data-tests-var3
)
432 (should-have-watch-data '(data-tests-var3-alias
433 data-tests-var3 defvaralias nil
))
434 (setq data-tests-var3
1)
435 (setq data-tests-var3-alias
2)
436 (should (null watch-data
)))))
438 (ert-deftest data-tests-local-variable-watchers
()
440 (defvar-local data-tests-lvar
0))
441 (let* ((buf1 (current-buffer))
445 (lambda (&rest args
) (push args watch-data
))))
446 (cl-flet ((should-have-watch-data (data)
447 (should (equal (pop watch-data
) data
))
448 (should (null watch-data
))))
449 (add-variable-watcher 'data-tests-lvar collect-watch-data
)
450 (setq data-tests-lvar
1)
451 (should-have-watch-data `(data-tests-lvar 1 set
,buf1
))
452 (let ((data-tests-lvar 2))
453 (should-have-watch-data `(data-tests-lvar 2 let
,buf1
))
454 (setq data-tests-lvar
3)
455 (should-have-watch-data `(data-tests-lvar 3 set
,buf1
)))
456 (should-have-watch-data `(data-tests-lvar 1 unlet
,buf1
))
457 (setq-default data-tests-lvar
4)
458 (should-have-watch-data `(data-tests-lvar 4 set nil
))
460 (setq buf2
(current-buffer))
461 (setq data-tests-lvar
1)
462 (should-have-watch-data `(data-tests-lvar 1 set
,buf2
))
463 (let ((data-tests-lvar 2))
464 (should-have-watch-data `(data-tests-lvar 2 let
,buf2
))
465 (setq data-tests-lvar
3)
466 (should-have-watch-data `(data-tests-lvar 3 set
,buf2
)))
467 (should-have-watch-data `(data-tests-lvar 1 unlet
,buf2
))
468 (kill-local-variable 'data-tests-lvar
)
469 (should-have-watch-data `(data-tests-lvar nil makunbound
,buf2
))
470 (setq data-tests-lvar
3.5)
471 (should-have-watch-data `(data-tests-lvar 3.5 set
,buf2
))
472 (kill-all-local-variables)
473 (should-have-watch-data `(data-tests-lvar nil makunbound
,buf2
)))
474 (setq-default data-tests-lvar
4)
475 (should-have-watch-data `(data-tests-lvar 4 set nil
))
476 (makunbound 'data-tests-lvar
)
477 (should-have-watch-data '(data-tests-lvar nil makunbound nil
))
478 (setq data-tests-lvar
5)
479 (should-have-watch-data `(data-tests-lvar 5 set
,buf1
))
480 (remove-variable-watcher 'data-tests-lvar collect-watch-data
)
481 (setq data-tests-lvar
6)
482 (should (null watch-data
)))))