Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 384:bbff43aa5eb7 r21-2-7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-7
author cvs
date Mon, 13 Aug 2007 11:08:24 +0200
parents
children aabb7f5b1c81
comparison
equal deleted inserted replaced
383:6a50c6a581a5 384:bbff43aa5eb7
1 ;; Copyright (C) 1998 Free Software Foundation, Inc.
2
3 ;; Author: Martin Buchholz <martin@xemacs.org>
4 ;; Maintainer: Martin Buchholz <martin@xemacs.org>
5 ;; Created: 1998
6 ;; Keywords: tests
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; 02111-1307, USA.
24
25 ;;; Synched up with: not in FSF Emacs.
26
27 ;;; Commentary:
28
29 ;;; Test basic Lisp engine functionality
30 ;;; See test-harness.el for instructions on how to run these tests.
31
32 (eval-when-compile
33 (condition-case nil
34 (require 'test-harness)
35 (file-error
36 (push "." load-path)
37 (when (and (boundp 'load-file-name) (stringp load-file-name))
38 (push (file-name-directory load-file-name) load-path))
39 (require 'test-harness))))
40
41 (Check-Error wrong-number-of-arguments (setq setq-test-foo))
42 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar))
43 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo))
44 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar))
45 (Assert (eq (setq) nil))
46 (Assert (eq (setq-default) nil))
47 (Assert (eq (setq setq-test-foo 42) 42))
48 (Assert (eq (setq-default setq-test-foo 42) 42))
49 (Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99))
50 (Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99))
51
52 (macrolet ((test-setq (expected-result &rest body)
53 `(progn
54 (defun test-setq-fun () ,@body)
55 (Assert (eq ,expected-result (test-setq-fun)))
56 (byte-compile 'test-setq-fun)
57 (Assert (eq ,expected-result (test-setq-fun))))))
58 (test-setq nil (setq))
59 (test-setq nil (setq-default))
60 (test-setq 42 (setq test-setq-var 42))
61 (test-setq 42 (setq-default test-setq-var 42))
62 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42))
63 (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42))
64 )
65
66 (let ((my-vector [1 2 3 4])
67 (my-bit-vector (bit-vector 1 0 1 0))
68 (my-string "1234")
69 (my-list '(1 2 3 4)))
70
71 ;;(Assert (fooooo)) ;; Generate Other failure
72 ;;(Assert (eq 1 2)) ;; Generate Assertion failure
73
74 (dolist (sequence (list my-vector my-bit-vector my-string my-list))
75 (Assert (sequencep sequence))
76 (Assert (eq 4 (length sequence))))
77
78 (dolist (array (list my-vector my-bit-vector my-string))
79 (Assert (arrayp array)))
80
81 (Assert (eq (elt my-vector 0) 1))
82 (Assert (eq (elt my-bit-vector 0) 1))
83 (Assert (eq (elt my-string 0) ?1))
84 (Assert (eq (elt my-list 0) 1))
85
86 (fillarray my-vector 5)
87 (fillarray my-bit-vector 1)
88 (fillarray my-string ?5)
89
90 (dolist (array (list my-vector my-bit-vector))
91 (Assert (eq 4 (length array))))
92
93 (Assert (eq (elt my-vector 0) 5))
94 (Assert (eq (elt my-bit-vector 0) 1))
95 (Assert (eq (elt my-string 0) ?5))
96
97 (Assert (eq (elt my-vector 3) 5))
98 (Assert (eq (elt my-bit-vector 3) 1))
99 (Assert (eq (elt my-string 3) ?5))
100
101 (fillarray my-bit-vector 0)
102 (Assert (eq 4 (length my-bit-vector)))
103 (Assert (eq (elt my-bit-vector 2) 0))
104 )
105
106 (defun make-circular-list (length)
107 "Create evil emacs-crashing circular list of length LENGTH"
108 (let ((circular-list
109 (make-list
110 length
111 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike)))
112 (setcdr (last circular-list) circular-list)
113 circular-list))
114
115 ;;-----------------------------------------------------
116 ;; Test `nconc'
117 ;;-----------------------------------------------------
118 (defun make-list-012 () (list 0 1 2))
119
120 (Check-Error wrong-type-argument (nconc 'foo nil))
121
122 (dolist (length `(1 2 3 4 1000 2000))
123 (Check-Error circular-list (nconc (make-circular-list length) 'foo))
124 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo))
125 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo)))
126
127 (Assert (eq (nconc) nil))
128 (Assert (eq (nconc nil) nil))
129 (Assert (eq (nconc nil nil) nil))
130 (Assert (eq (nconc nil nil nil) nil))
131
132 (let ((x (make-list-012))) (Assert (eq (nconc nil x) x)))
133 (let ((x (make-list-012))) (Assert (eq (nconc x nil) x)))
134 (let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x)))
135 (let ((x (make-list-012))) (Assert (eq (nconc x) x)))
136 (let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x)))
137
138 (Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6)))
139
140 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil)))
141 (Assert (eq (length y) 6))
142 (Assert (eq (nth 3 y) 3)))
143
144 ;;-----------------------------------------------------
145 ;; Test `last'
146 ;;-----------------------------------------------------
147 (Check-Error wrong-type-argument (last 'foo))
148 (Check-Error wrong-number-of-arguments (last))
149 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1))
150 (Check-Error circular-list (last (make-circular-list 1)))
151 (Check-Error circular-list (last (make-circular-list 2000)))
152 (let ((x (list 0 1 2 3)))
153 (Assert (eq (last nil) nil))
154 (Assert (eq (last x 0) nil))
155 (Assert (eq (last x ) (cdddr x)))
156 (Assert (eq (last x 1) (cdddr x)))
157 (Assert (eq (last x 2) (cddr x)))
158 (Assert (eq (last x 3) (cdr x)))
159 (Assert (eq (last x 4) x))
160 (Assert (eq (last x 9) x))
161 (Assert (eq (last `(1 . 2) 0) 2))
162 )
163
164 ;;-----------------------------------------------------
165 ;; Test `butlast' and `nbutlast'
166 ;;-----------------------------------------------------
167 (Check-Error wrong-type-argument (butlast 'foo))
168 (Check-Error wrong-type-argument (nbutlast 'foo))
169 (Check-Error wrong-number-of-arguments (butlast))
170 (Check-Error wrong-number-of-arguments (nbutlast))
171 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1))
172 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1))
173 (Check-Error circular-list (butlast (make-circular-list 1)))
174 (Check-Error circular-list (nbutlast (make-circular-list 1)))
175 (Check-Error circular-list (butlast (make-circular-list 2000)))
176 (Check-Error circular-list (nbutlast (make-circular-list 2000)))
177
178 (let* ((x (list 0 1 2 3))
179 (y (butlast x))
180 (z (nbutlast x)))
181 (Assert (eq z x))
182 (Assert (not (eq y x)))
183 (Assert (equal y '(0 1 2)))
184 (Assert (equal z y)))
185
186 (let* ((x (list 0 1 2 3 4))
187 (y (butlast x 2))
188 (z (nbutlast x 2)))
189 (Assert (eq z x))
190 (Assert (not (eq y x)))
191 (Assert (equal y '(0 1 2)))
192 (Assert (equal z y)))
193
194 (let* ((x (list 0 1 2 3))
195 (y (butlast x 0))
196 (z (nbutlast x 0)))
197 (Assert (eq z x))
198 (Assert (not (eq y x)))
199 (Assert (equal y '(0 1 2 3)))
200 (Assert (equal z y)))
201
202 (Assert (eq (butlast '(x)) nil))
203 (Assert (eq (nbutlast '(x)) nil))
204 (Assert (eq (butlast '()) nil))
205 (Assert (eq (nbutlast '()) nil))
206
207 ;;-----------------------------------------------------
208 ;; Test `copy-list'
209 ;;-----------------------------------------------------
210 (Check-Error wrong-type-argument (copy-list 'foo))
211 (Check-Error wrong-number-of-arguments (copy-list))
212 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1))
213 (Check-Error circular-list (copy-list (make-circular-list 1)))
214 (Check-Error circular-list (copy-list (make-circular-list 2000)))
215 (Assert (eq '() (copy-list '())))
216 (dolist (x `((1) (1 2) (1 2 3) (1 2 . 3)))
217 (let ((y (copy-list x)))
218 (Assert (and (equal x y) (not (eq x y))))))
219
220 ;;-----------------------------------------------------
221 ;; Arithmetic operations
222 ;;-----------------------------------------------------
223
224 ;; Test `+'
225 (Assert (eq (+ 1 1) 2))
226 (Assert (= (+ 1.0 1.0) 2.0))
227 (Assert (= (+ 1.0 3.0 0.0) 4.0))
228 (Assert (= (+ 1 1.0) 2.0))
229 (Assert (= (+ 1.0 1) 2.0))
230 (Assert (= (+ 1.0 1 1) 3.0))
231 (Assert (= (+ 1 1 1.0) 3.0))
232
233 ;; Test `-'
234 (Check-Error wrong-number-of-arguments (-))
235 (Assert (eq (- 0) 0))
236 (Assert (eq (- 1) -1))
237 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1)))
238 (Assert (= (+ 1 one) 2))
239 (Assert (= (+ one) 1))
240 (Assert (= (+ one) one))
241 (Assert (= (- one) -1))
242 (Assert (= (- one one) 0))
243 (Assert (= (- one one one) -1))
244 (Assert (= (+ one 1) 2))
245 (dolist (zero `(0 0.0 ?\0))
246 (Assert (= (+ 1 zero) 1))
247 (Assert (= (+ zero 1) 1))
248 (Assert (= (- zero) zero))
249 (Assert (= (- zero) 0))
250 (Assert (= (- zero zero) 0))
251 (Assert (= (- zero one one) -2))))
252
253 (Assert (= (- 1.5 1) .5))
254 (Assert (= (- 1 1.5) (- .5)))
255
256 ;; Test `/'
257
258 ;; Test division by zero errors
259 (dolist (zero `(0 0.0 ?\0))
260 (Check-Error arith-error (/ zero))
261 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
262 (Check-Error arith-error (/ n1 zero))
263 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3)))
264 (Check-Error arith-error (/ n1 n2 zero)))))
265
266 ;; Other tests for `/'
267 (Check-Error wrong-number-of-arguments (/))
268 (let (x)
269 (Assert (= (/ (setq x 2)) 0))
270 (Assert (= (/ (setq x 2.0)) 0.5)))
271
272 (dolist (six `(6 6.0 ?\06))
273 (dolist (two `(2 2.0 ?\02))
274 (dolist (three `(3 3.0 ?\03))
275 (Assert (= (/ six two) three)))))
276
277 (dolist (three `(3 3.0 ?\03))
278 (Assert (= (/ three 2.0) 1.5)))
279 (dolist (two `(2 2.0 ?\02))
280 (Assert (= (/ 3.0 two) 1.5)))
281
282 ;; Test `*'
283 (Assert (= 1 (*)))
284
285 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
286 (Assert (= 1 (* one))))
287
288 (dolist (two `(2 2.0 ?\02))
289 (Assert (= 2 (* two))))
290
291 (dolist (six `(6 6.0 ?\06))
292 (dolist (two `(2 2.0 ?\02))
293 (dolist (three `(3 3.0 ?\03))
294 (Assert (= (* three two) six)))))
295
296 (dolist (three `(3 3.0 ?\03))
297 (dolist (two `(2 2.0 ?\02))
298 (Assert (= (* 1.5 two) three))
299 (dolist (five `(5 5.0 ?\05))
300 (Assert (= 30 (* five two three))))))
301
302 ;; Test `+'
303 (Assert (= 0 (+)))
304
305 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
306 (Assert (= 1 (+ one))))
307
308 (dolist (two `(2 2.0 ?\02))
309 (Assert (= 2 (+ two))))
310
311 (dolist (five `(5 5.0 ?\05))
312 (dolist (two `(2 2.0 ?\02))
313 (dolist (three `(3 3.0 ?\03))
314 (Assert (= (+ three two) five))
315 (Assert (= 10 (+ five two three))))))
316
317 ;; Test `max', `min'
318 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
319 (Assert (= one (max one)))
320 (Assert (= one (max one one)))
321 (Assert (= one (max one one one)))
322 (Assert (= one (min one)))
323 (Assert (= one (min one one)))
324 (Assert (= one (min one one one)))
325 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2)))
326 (Assert (= one (min one two)))
327 (Assert (= one (min one two two)))
328 (Assert (= one (min two two one)))
329 (Assert (= two (max one two)))
330 (Assert (= two (max one two two)))
331 (Assert (= two (max two two one)))))
332
333 ;;-----------------------------------------------------
334 ;; Logical bit-twiddling operations
335 ;;-----------------------------------------------------
336 (Assert (= (logxor) 0))
337 (Assert (= (logior) 0))
338 (Assert (= (logand) -1))
339
340 (Check-Error wrong-type-argument (logxor 3.0))
341 (Check-Error wrong-type-argument (logior 3.0))
342 (Check-Error wrong-type-argument (logand 3.0))
343
344 (dolist (three `(3 ?\03))
345 (Assert (eq 3 (logand three)))
346 (Assert (eq 3 (logxor three)))
347 (Assert (eq 3 (logior three)))
348 (Assert (eq 3 (logand three three)))
349 (Assert (eq 0 (logxor three three)))
350 (Assert (eq 3 (logior three three))))
351
352 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
353 (dolist (two `(2 ?\02))
354 (Assert (eq 0 (logand one two)))
355 (Assert (eq 3 (logior one two)))
356 (Assert (eq 3 (logxor one two))))
357 (dolist (three `(3 ?\03))
358 (Assert (eq 1 (logand one three)))
359 (Assert (eq 3 (logior one three)))
360 (Assert (eq 2 (logxor one three)))))
361
362 ;;-----------------------------------------------------
363 ;; Test `%', mod
364 ;;-----------------------------------------------------
365 (Check-Error wrong-number-of-arguments (%))
366 (Check-Error wrong-number-of-arguments (% 1))
367 (Check-Error wrong-number-of-arguments (% 1 2 3))
368
369 (Check-Error wrong-number-of-arguments (mod))
370 (Check-Error wrong-number-of-arguments (mod 1))
371 (Check-Error wrong-number-of-arguments (mod 1 2 3))
372
373 (Check-Error wrong-type-argument (% 10.0 2))
374 (Check-Error wrong-type-argument (% 10 2.0))
375
376 (dotimes (j 30)
377 (let ((x (- (random) (random))))
378 (Assert (eq x (+ (% x 17) (* (/ x 17) 17))))
379 (Assert (eq (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))))
380 (Assert (eq (% x -17) (- (% (- x) 17))))
381 ))
382
383 (macrolet
384 ((division-test (seven)
385 `(progn
386 (Assert (eq (% ,seven 2) 1))
387 (Assert (eq (% ,seven -2) 1))
388 (Assert (eq (% (- ,seven) 2) -1))
389 (Assert (eq (% (- ,seven) -2) -1))
390
391 (Assert (eq (% ,seven 4) 3))
392 (Assert (eq (% ,seven -4) 3))
393 (Assert (eq (% (- ,seven) 4) -3))
394 (Assert (eq (% (- ,seven) -4) -3))
395
396 (Assert (eq (% 35 ,seven) 0))
397 (Assert (eq (% -35 ,seven) 0))
398 (Assert (eq (% 35 (- ,seven)) 0))
399 (Assert (eq (% -35 (- ,seven)) 0))
400
401 (Assert (eq (mod ,seven 2) 1))
402 (Assert (eq (mod ,seven -2) -1))
403 (Assert (eq (mod (- ,seven) 2) 1))
404 (Assert (eq (mod (- ,seven) -2) -1))
405
406 (Assert (eq (mod ,seven 4) 3))
407 (Assert (eq (mod ,seven -4) -1))
408 (Assert (eq (mod (- ,seven) 4) 1))
409 (Assert (eq (mod (- ,seven) -4) -3))
410
411 (Assert (eq (mod 35 ,seven) 0))
412 (Assert (eq (mod -35 ,seven) 0))
413 (Assert (eq (mod 35 (- ,seven)) 0))
414 (Assert (eq (mod -35 (- ,seven)) 0))
415
416 (Assert (= (mod ,seven 2.0) 1.0))
417 (Assert (= (mod ,seven -2.0) -1.0))
418 (Assert (= (mod (- ,seven) 2.0) 1.0))
419 (Assert (= (mod (- ,seven) -2.0) -1.0))
420
421 (Assert (= (mod ,seven 4.0) 3.0))
422 (Assert (= (mod ,seven -4.0) -1.0))
423 (Assert (= (mod (- ,seven) 4.0) 1.0))
424 (Assert (= (mod (- ,seven) -4.0) -3.0))
425
426 (Assert (eq (% 0 ,seven) 0))
427 (Assert (eq (% 0 (- ,seven)) 0))
428
429 (Assert (eq (mod 0 ,seven) 0))
430 (Assert (eq (mod 0 (- ,seven)) 0))
431
432 (Assert (= (mod 0.0 ,seven) 0.0))
433 (Assert (= (mod 0.0 (- ,seven)) 0.0)))))
434
435 (division-test 7)
436 (division-test ?\07)
437 (division-test (Int-to-Marker 7)))
438
439
440
441 ;;-----------------------------------------------------
442 ;; Arithmetic comparison operations
443 ;;-----------------------------------------------------
444 (Check-Error wrong-number-of-arguments (=))
445 (Check-Error wrong-number-of-arguments (<))
446 (Check-Error wrong-number-of-arguments (>))
447 (Check-Error wrong-number-of-arguments (<=))
448 (Check-Error wrong-number-of-arguments (>=))
449 (Check-Error wrong-number-of-arguments (/=))
450
451 ;; One argument always yields t
452 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do
453 (Assert (eq t (= x)))
454 (Assert (eq t (< x)))
455 (Assert (eq t (> x)))
456 (Assert (eq t (>= x)))
457 (Assert (eq t (<= x)))
458 (Assert (eq t (/= x)))
459 )
460
461 ;; Type checking
462 (Check-Error wrong-type-argument (= 'foo 1))
463 (Check-Error wrong-type-argument (<= 'foo 1))
464 (Check-Error wrong-type-argument (>= 'foo 1))
465 (Check-Error wrong-type-argument (< 'foo 1))
466 (Check-Error wrong-type-argument (> 'foo 1))
467 (Check-Error wrong-type-argument (/= 'foo 1))
468
469 ;; Meat
470 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
471 (dolist (two `(2 2.0 ?\02))
472 (Assert (< one two))
473 (Assert (<= one two))
474 (Assert (<= two two))
475 (Assert (> two one))
476 (Assert (>= two one))
477 (Assert (>= two two))
478 (Assert (/= one two))
479 (Assert (not (/= two two)))
480 (Assert (not (< one one)))
481 (Assert (not (> one one)))
482 (Assert (<= one one two two))
483 (Assert (not (< one one two two)))
484 (Assert (>= two two one one))
485 (Assert (not (> two two one one)))
486 (Assert (= one one one))
487 (Assert (not (= one one one two)))
488 (Assert (not (/= one two one)))
489 ))
490
491 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
492 (dolist (two `(2 2.0 ?\02))
493 (Assert (< one two))
494 (Assert (<= one two))
495 (Assert (<= two two))
496 (Assert (> two one))
497 (Assert (>= two one))
498 (Assert (>= two two))
499 (Assert (/= one two))
500 (Assert (not (/= two two)))
501 (Assert (not (< one one)))
502 (Assert (not (> one one)))
503 (Assert (<= one one two two))
504 (Assert (not (< one one two two)))
505 (Assert (>= two two one one))
506 (Assert (not (> two two one one)))
507 (Assert (= one one one))
508 (Assert (not (= one one one two)))
509 (Assert (not (/= one two one)))
510 ))
511
512 ;; ad-hoc
513 (Assert (< 1 2))
514 (Assert (< 1 2 3 4 5 6))
515 (Assert (not (< 1 1)))
516 (Assert (not (< 2 1)))
517
518
519 (Assert (not (< 1 1)))
520 (Assert (< 1 2 3 4 5 6))
521 (Assert (<= 1 2 3 4 5 6))
522 (Assert (<= 1 2 3 4 5 6 6))
523 (Assert (not (< 1 2 3 4 5 6 6)))
524 (Assert (<= 1 1))
525
526 (Assert (not (eq (point) (point-marker))))
527 (Assert (= 1 (Int-to-Marker 1)))
528 (Assert (= (point) (point-marker)))
529
530 ;;-----------------------------------------------------
531 ;; testing list-walker functions
532 ;;-----------------------------------------------------
533 (macrolet
534 ((test-fun
535 (fun)
536 `(progn
537 (Check-Error wrong-number-of-arguments (,fun))
538 (Check-Error wrong-number-of-arguments (,fun nil))
539 (Check-Error malformed-list (,fun nil 1))
540 ,@(loop for n in `(1 2 2000)
541 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
542 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))))
543
544 (test-funs member old-member
545 memq old-memq
546 assoc old-assoc
547 rassoc old-rassoc
548 rassq old-rassq
549 delete old-delete
550 delq old-delq
551 remassoc remassq remrassoc remrassq))
552
553 (let ((x '((1 . 2) 3 (4 . 5))))
554 (Assert (eq (assoc 1 x) (car x)))
555 (Assert (eq (assq 1 x) (car x)))
556 (Assert (eq (rassoc 1 x) nil))
557 (Assert (eq (rassq 1 x) nil))
558 (Assert (eq (assoc 2 x) nil))
559 (Assert (eq (assq 2 x) nil))
560 (Assert (eq (rassoc 2 x) (car x)))
561 (Assert (eq (rassq 2 x) (car x)))
562 (Assert (eq (assoc 3 x) nil))
563 (Assert (eq (assq 3 x) nil))
564 (Assert (eq (rassoc 3 x) nil))
565 (Assert (eq (rassq 3 x) nil))
566 (Assert (eq (assoc 4 x) (caddr x)))
567 (Assert (eq (assq 4 x) (caddr x)))
568 (Assert (eq (rassoc 4 x) nil))
569 (Assert (eq (rassq 4 x) nil))
570 (Assert (eq (assoc 5 x) nil))
571 (Assert (eq (assq 5 x) nil))
572 (Assert (eq (rassoc 5 x) (caddr x)))
573 (Assert (eq (rassq 5 x) (caddr x)))
574 (Assert (eq (assoc 6 x) nil))
575 (Assert (eq (assq 6 x) nil))
576 (Assert (eq (rassoc 6 x) nil))
577 (Assert (eq (rassq 6 x) nil)))
578
579 (let ((x '(("1" . "2") "3" ("4" . "5"))))
580 (Assert (eq (assoc "1" x) (car x)))
581 (Assert (eq (assq "1" x) nil))
582 (Assert (eq (rassoc "1" x) nil))
583 (Assert (eq (rassq "1" x) nil))
584 (Assert (eq (assoc "2" x) nil))
585 (Assert (eq (assq "2" x) nil))
586 (Assert (eq (rassoc "2" x) (car x)))
587 (Assert (eq (rassq "2" x) nil))
588 (Assert (eq (assoc "3" x) nil))
589 (Assert (eq (assq "3" x) nil))
590 (Assert (eq (rassoc "3" x) nil))
591 (Assert (eq (rassq "3" x) nil))
592 (Assert (eq (assoc "4" x) (caddr x)))
593 (Assert (eq (assq "4" x) nil))
594 (Assert (eq (rassoc "4" x) nil))
595 (Assert (eq (rassq "4" x) nil))
596 (Assert (eq (assoc "5" x) nil))
597 (Assert (eq (assq "5" x) nil))
598 (Assert (eq (rassoc "5" x) (caddr x)))
599 (Assert (eq (rassq "5" x) nil))
600 (Assert (eq (assoc "6" x) nil))
601 (Assert (eq (assq "6" x) nil))
602 (Assert (eq (rassoc "6" x) nil))
603 (Assert (eq (rassq "6" x) nil)))
604
605 (flet ((a () (list '(1 . 2) 3 '(4 . 5))))
606 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
607 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
608 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a)))))
609 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a)))))
610
611 (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a)))))
612 (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a)))))
613 (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
614 (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
615
616 (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a)))))
617 (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a)))))
618 (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a)))))
619 (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a)))))
620
621 (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
622 (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
623 (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a)))))
624 (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a)))))
625
626 (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a)))))
627 (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a)))))
628 (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
629 (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
630
631 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a)))))
632 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a)))))
633 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a)))))
634 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a)))))
635
636 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
637 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
638 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
639 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
640
641 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
642 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
643 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
644 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
645 )
646
647
648
649 (flet ((a () (list '("1" . "2") "3" '("4" . "5"))))
650 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
651 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a)))))
652 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a)))))
653 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a)))))
654
655 (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a)))))
656 (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a)))))
657 (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
658 (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a)))))
659
660 (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a)))))
661 (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a)))))
662 (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a)))))
663 (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a)))))
664
665 (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
666 (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a)))))
667 (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a)))))
668 (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a)))))
669
670 (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a)))))
671 (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a)))))
672 (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
673 (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a)))))
674
675 (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a)))))
676 (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a)))))
677 (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a)))))
678 (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a))))))
679
680 ;;-----------------------------------------------------
681 ;; function-max-args, function-min-args
682 ;;-----------------------------------------------------
683 (defmacro check-function-argcounts (fun min max)
684 `(progn
685 (Assert (eq (function-min-args ,fun) ,min))
686 (Assert (eq (function-max-args ,fun) ,max))))
687
688 (check-function-argcounts 'prog1 1 nil) ; special form
689 (check-function-argcounts 'command-execute 1 3) ; normal subr
690 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr
691 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
692
693 ;; Test interpreted and compiled functions
694 (loop for (arglist min max) in
695 '(((arg1 arg2 &rest args) 2 nil)
696 ((arg1 arg2 &optional arg3 arg4) 2 4)
697 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil)
698 (() 0 0))
699 do
700 (eval
701 `(progn
702 (defun test-fun ,arglist nil)
703 (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
704 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
705
706 ;;-----------------------------------------------------
707 ;; Detection of cyclic variable indirection loops
708 ;;-----------------------------------------------------
709 (fset 'test-sym1 'test-sym1)
710 (Check-Error cyclic-function-indirection (test-sym1))
711
712 (fset 'test-sym1 'test-sym2)
713 (fset 'test-sym2 'test-sym1)
714 (Check-Error cyclic-function-indirection (test-sym1))
715 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops!
716 (fmakunbound 'test-sym2)
717
718 ;;-----------------------------------------------------
719 ;; Test `type-of'
720 ;;-----------------------------------------------------
721 (Assert (eq (type-of load-path) 'cons))
722 (Assert (eq (type-of obarray) 'vector))
723 (Assert (eq (type-of 42) 'integer))
724 (Assert (eq (type-of ?z) 'character))
725 (Assert (eq (type-of "42") 'string))
726 (Assert (eq (type-of 'foo) 'symbol))
727 (Assert (eq (type-of (selected-device)) 'device))
728
729 ;;-----------------------------------------------------
730 ;; Test mapping functions
731 ;;-----------------------------------------------------
732 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer)))
733 (Assert (equal (mapcar #'identity load-path) load-path))
734 (Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3)))
735 (Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3)))
736 (Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3)))
737 (Assert (equal (mapcar #'identity #*010) '(0 1 0)))
738
739 (let ((z 0) (list (make-list 1000 1)))
740 (mapc (lambda (x) (incf z x)) list)
741 (Assert (eq 1000 z)))
742
743 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer)))
744 (Assert (equal (mapvector #'identity '(1 2 3)) [1 2 3]))
745 (Assert (equal (mapvector #'identity "123") [?1 ?2 ?3]))
746 (Assert (equal (mapvector #'identity [1 2 3]) [1 2 3]))
747 (Assert (equal (mapvector #'identity #*010) [0 1 0]))
748
749 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo"))
750 (Assert (equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3"))
751 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3"))
752
753 ;;-----------------------------------------------------
754 ;; Test vector functions
755 ;;-----------------------------------------------------
756 (Assert (equal [1 2 3] [1 2 3]))
757 (Assert (equal [] []))
758 (Assert (not (equal [1 2 3] [])))
759 (Assert (not (equal [1 2 3] [1 2 4])))
760 (Assert (not (equal [0 2 3] [1 2 3])))
761 (Assert (not (equal [1 2 3] [1 2 3 4])))
762 (Assert (not (equal [1 2 3 4] [1 2 3])))
763 (Assert (equal (vector 1 2 3) [1 2 3]))
764 (Assert (equal (make-vector 3 1) [1 1 1]))
765
766 ;;-----------------------------------------------------
767 ;; Test bit-vector functions
768 ;;-----------------------------------------------------
769 (Assert (equal #*010 #*010))
770 (Assert (equal #* #*))
771 (Assert (not (equal #*010 #*011)))
772 (Assert (not (equal #*010 #*)))
773 (Assert (not (equal #*110 #*010)))
774 (Assert (not (equal #*010 #*0100)))
775 (Assert (not (equal #*0101 #*010)))
776 (Assert (equal (bit-vector 0 1 0) #*010))
777 (Assert (equal (make-bit-vector 3 1) #*111))
778 (Assert (equal (make-bit-vector 3 0) #*000))