|
380
|
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))
|
