|
384
|
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
|
|
398
|
25 ;;; Synched up with: Not in FSF.
|
|
384
|
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
|
|
398
|
122 (dolist (length '(1 2 3 4 1000 2000))
|
|
384
|
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))
|
|
398
|
161 (Assert (eq (last '(1 . 2) 0) 2))
|
|
384
|
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 '())))
|
|
398
|
216 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
|
|
384
|
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))
|
|
398
|
232 (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum))
|
|
|
233 (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum))
|
|
384
|
234
|
|
|
235 ;; Test `-'
|
|
|
236 (Check-Error wrong-number-of-arguments (-))
|
|
|
237 (Assert (eq (- 0) 0))
|
|
|
238 (Assert (eq (- 1) -1))
|
|
|
239 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1)))
|
|
|
240 (Assert (= (+ 1 one) 2))
|
|
|
241 (Assert (= (+ one) 1))
|
|
|
242 (Assert (= (+ one) one))
|
|
|
243 (Assert (= (- one) -1))
|
|
|
244 (Assert (= (- one one) 0))
|
|
|
245 (Assert (= (- one one one) -1))
|
|
|
246 (Assert (= (+ one 1) 2))
|
|
398
|
247 (dolist (zero '(0 0.0 ?\0))
|
|
384
|
248 (Assert (= (+ 1 zero) 1))
|
|
|
249 (Assert (= (+ zero 1) 1))
|
|
|
250 (Assert (= (- zero) zero))
|
|
|
251 (Assert (= (- zero) 0))
|
|
|
252 (Assert (= (- zero zero) 0))
|
|
|
253 (Assert (= (- zero one one) -2))))
|
|
|
254
|
|
|
255 (Assert (= (- 1.5 1) .5))
|
|
|
256 (Assert (= (- 1 1.5) (- .5)))
|
|
|
257
|
|
398
|
258 (Assert (eq (1- most-negative-fixnum) most-positive-fixnum))
|
|
|
259 (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum))
|
|
|
260
|
|
384
|
261 ;; Test `/'
|
|
|
262
|
|
|
263 ;; Test division by zero errors
|
|
398
|
264 (dolist (zero '(0 0.0 ?\0))
|
|
384
|
265 (Check-Error arith-error (/ zero))
|
|
|
266 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
|
|
|
267 (Check-Error arith-error (/ n1 zero))
|
|
|
268 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3)))
|
|
|
269 (Check-Error arith-error (/ n1 n2 zero)))))
|
|
|
270
|
|
|
271 ;; Other tests for `/'
|
|
|
272 (Check-Error wrong-number-of-arguments (/))
|
|
|
273 (let (x)
|
|
|
274 (Assert (= (/ (setq x 2)) 0))
|
|
|
275 (Assert (= (/ (setq x 2.0)) 0.5)))
|
|
|
276
|
|
398
|
277 (dolist (six '(6 6.0 ?\06))
|
|
|
278 (dolist (two '(2 2.0 ?\02))
|
|
|
279 (dolist (three '(3 3.0 ?\03))
|
|
384
|
280 (Assert (= (/ six two) three)))))
|
|
|
281
|
|
398
|
282 (dolist (three '(3 3.0 ?\03))
|
|
384
|
283 (Assert (= (/ three 2.0) 1.5)))
|
|
398
|
284 (dolist (two '(2 2.0 ?\02))
|
|
384
|
285 (Assert (= (/ 3.0 two) 1.5)))
|
|
|
286
|
|
|
287 ;; Test `*'
|
|
|
288 (Assert (= 1 (*)))
|
|
|
289
|
|
|
290 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
|
|
|
291 (Assert (= 1 (* one))))
|
|
|
292
|
|
398
|
293 (dolist (two '(2 2.0 ?\02))
|
|
384
|
294 (Assert (= 2 (* two))))
|
|
|
295
|
|
398
|
296 (dolist (six '(6 6.0 ?\06))
|
|
|
297 (dolist (two '(2 2.0 ?\02))
|
|
|
298 (dolist (three '(3 3.0 ?\03))
|
|
384
|
299 (Assert (= (* three two) six)))))
|
|
|
300
|
|
398
|
301 (dolist (three '(3 3.0 ?\03))
|
|
|
302 (dolist (two '(2 2.0 ?\02))
|
|
384
|
303 (Assert (= (* 1.5 two) three))
|
|
398
|
304 (dolist (five '(5 5.0 ?\05))
|
|
384
|
305 (Assert (= 30 (* five two three))))))
|
|
|
306
|
|
|
307 ;; Test `+'
|
|
|
308 (Assert (= 0 (+)))
|
|
|
309
|
|
|
310 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
|
|
|
311 (Assert (= 1 (+ one))))
|
|
|
312
|
|
398
|
313 (dolist (two '(2 2.0 ?\02))
|
|
384
|
314 (Assert (= 2 (+ two))))
|
|
|
315
|
|
398
|
316 (dolist (five '(5 5.0 ?\05))
|
|
|
317 (dolist (two '(2 2.0 ?\02))
|
|
|
318 (dolist (three '(3 3.0 ?\03))
|
|
384
|
319 (Assert (= (+ three two) five))
|
|
|
320 (Assert (= 10 (+ five two three))))))
|
|
|
321
|
|
|
322 ;; Test `max', `min'
|
|
|
323 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
|
|
|
324 (Assert (= one (max one)))
|
|
|
325 (Assert (= one (max one one)))
|
|
|
326 (Assert (= one (max one one one)))
|
|
|
327 (Assert (= one (min one)))
|
|
|
328 (Assert (= one (min one one)))
|
|
|
329 (Assert (= one (min one one one)))
|
|
|
330 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2)))
|
|
|
331 (Assert (= one (min one two)))
|
|
|
332 (Assert (= one (min one two two)))
|
|
|
333 (Assert (= one (min two two one)))
|
|
|
334 (Assert (= two (max one two)))
|
|
|
335 (Assert (= two (max one two two)))
|
|
|
336 (Assert (= two (max two two one)))))
|
|
|
337
|
|
|
338 ;;-----------------------------------------------------
|
|
|
339 ;; Logical bit-twiddling operations
|
|
|
340 ;;-----------------------------------------------------
|
|
|
341 (Assert (= (logxor) 0))
|
|
|
342 (Assert (= (logior) 0))
|
|
|
343 (Assert (= (logand) -1))
|
|
|
344
|
|
|
345 (Check-Error wrong-type-argument (logxor 3.0))
|
|
|
346 (Check-Error wrong-type-argument (logior 3.0))
|
|
|
347 (Check-Error wrong-type-argument (logand 3.0))
|
|
|
348
|
|
398
|
349 (dolist (three '(3 ?\03))
|
|
384
|
350 (Assert (eq 3 (logand three)))
|
|
|
351 (Assert (eq 3 (logxor three)))
|
|
|
352 (Assert (eq 3 (logior three)))
|
|
|
353 (Assert (eq 3 (logand three three)))
|
|
|
354 (Assert (eq 0 (logxor three three)))
|
|
|
355 (Assert (eq 3 (logior three three))))
|
|
|
356
|
|
|
357 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
|
|
398
|
358 (dolist (two '(2 ?\02))
|
|
384
|
359 (Assert (eq 0 (logand one two)))
|
|
|
360 (Assert (eq 3 (logior one two)))
|
|
|
361 (Assert (eq 3 (logxor one two))))
|
|
398
|
362 (dolist (three '(3 ?\03))
|
|
384
|
363 (Assert (eq 1 (logand one three)))
|
|
|
364 (Assert (eq 3 (logior one three)))
|
|
|
365 (Assert (eq 2 (logxor one three)))))
|
|
|
366
|
|
|
367 ;;-----------------------------------------------------
|
|
|
368 ;; Test `%', mod
|
|
|
369 ;;-----------------------------------------------------
|
|
|
370 (Check-Error wrong-number-of-arguments (%))
|
|
|
371 (Check-Error wrong-number-of-arguments (% 1))
|
|
|
372 (Check-Error wrong-number-of-arguments (% 1 2 3))
|
|
|
373
|
|
|
374 (Check-Error wrong-number-of-arguments (mod))
|
|
|
375 (Check-Error wrong-number-of-arguments (mod 1))
|
|
|
376 (Check-Error wrong-number-of-arguments (mod 1 2 3))
|
|
|
377
|
|
|
378 (Check-Error wrong-type-argument (% 10.0 2))
|
|
|
379 (Check-Error wrong-type-argument (% 10 2.0))
|
|
|
380
|
|
|
381 (dotimes (j 30)
|
|
|
382 (let ((x (- (random) (random))))
|
|
|
383 (Assert (eq x (+ (% x 17) (* (/ x 17) 17))))
|
|
|
384 (Assert (eq (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))))
|
|
|
385 (Assert (eq (% x -17) (- (% (- x) 17))))
|
|
|
386 ))
|
|
|
387
|
|
|
388 (macrolet
|
|
|
389 ((division-test (seven)
|
|
|
390 `(progn
|
|
|
391 (Assert (eq (% ,seven 2) 1))
|
|
|
392 (Assert (eq (% ,seven -2) 1))
|
|
|
393 (Assert (eq (% (- ,seven) 2) -1))
|
|
|
394 (Assert (eq (% (- ,seven) -2) -1))
|
|
|
395
|
|
|
396 (Assert (eq (% ,seven 4) 3))
|
|
|
397 (Assert (eq (% ,seven -4) 3))
|
|
|
398 (Assert (eq (% (- ,seven) 4) -3))
|
|
|
399 (Assert (eq (% (- ,seven) -4) -3))
|
|
|
400
|
|
|
401 (Assert (eq (% 35 ,seven) 0))
|
|
|
402 (Assert (eq (% -35 ,seven) 0))
|
|
|
403 (Assert (eq (% 35 (- ,seven)) 0))
|
|
|
404 (Assert (eq (% -35 (- ,seven)) 0))
|
|
|
405
|
|
|
406 (Assert (eq (mod ,seven 2) 1))
|
|
|
407 (Assert (eq (mod ,seven -2) -1))
|
|
|
408 (Assert (eq (mod (- ,seven) 2) 1))
|
|
|
409 (Assert (eq (mod (- ,seven) -2) -1))
|
|
|
410
|
|
|
411 (Assert (eq (mod ,seven 4) 3))
|
|
|
412 (Assert (eq (mod ,seven -4) -1))
|
|
|
413 (Assert (eq (mod (- ,seven) 4) 1))
|
|
|
414 (Assert (eq (mod (- ,seven) -4) -3))
|
|
|
415
|
|
|
416 (Assert (eq (mod 35 ,seven) 0))
|
|
|
417 (Assert (eq (mod -35 ,seven) 0))
|
|
|
418 (Assert (eq (mod 35 (- ,seven)) 0))
|
|
|
419 (Assert (eq (mod -35 (- ,seven)) 0))
|
|
|
420
|
|
|
421 (Assert (= (mod ,seven 2.0) 1.0))
|
|
|
422 (Assert (= (mod ,seven -2.0) -1.0))
|
|
|
423 (Assert (= (mod (- ,seven) 2.0) 1.0))
|
|
|
424 (Assert (= (mod (- ,seven) -2.0) -1.0))
|
|
|
425
|
|
|
426 (Assert (= (mod ,seven 4.0) 3.0))
|
|
|
427 (Assert (= (mod ,seven -4.0) -1.0))
|
|
|
428 (Assert (= (mod (- ,seven) 4.0) 1.0))
|
|
|
429 (Assert (= (mod (- ,seven) -4.0) -3.0))
|
|
|
430
|
|
|
431 (Assert (eq (% 0 ,seven) 0))
|
|
|
432 (Assert (eq (% 0 (- ,seven)) 0))
|
|
|
433
|
|
|
434 (Assert (eq (mod 0 ,seven) 0))
|
|
|
435 (Assert (eq (mod 0 (- ,seven)) 0))
|
|
|
436
|
|
|
437 (Assert (= (mod 0.0 ,seven) 0.0))
|
|
|
438 (Assert (= (mod 0.0 (- ,seven)) 0.0)))))
|
|
|
439
|
|
|
440 (division-test 7)
|
|
|
441 (division-test ?\07)
|
|
|
442 (division-test (Int-to-Marker 7)))
|
|
|
443
|
|
|
444
|
|
|
445
|
|
|
446 ;;-----------------------------------------------------
|
|
|
447 ;; Arithmetic comparison operations
|
|
|
448 ;;-----------------------------------------------------
|
|
|
449 (Check-Error wrong-number-of-arguments (=))
|
|
|
450 (Check-Error wrong-number-of-arguments (<))
|
|
|
451 (Check-Error wrong-number-of-arguments (>))
|
|
|
452 (Check-Error wrong-number-of-arguments (<=))
|
|
|
453 (Check-Error wrong-number-of-arguments (>=))
|
|
|
454 (Check-Error wrong-number-of-arguments (/=))
|
|
|
455
|
|
|
456 ;; One argument always yields t
|
|
|
457 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do
|
|
|
458 (Assert (eq t (= x)))
|
|
|
459 (Assert (eq t (< x)))
|
|
|
460 (Assert (eq t (> x)))
|
|
|
461 (Assert (eq t (>= x)))
|
|
|
462 (Assert (eq t (<= x)))
|
|
|
463 (Assert (eq t (/= x)))
|
|
|
464 )
|
|
|
465
|
|
|
466 ;; Type checking
|
|
|
467 (Check-Error wrong-type-argument (= 'foo 1))
|
|
|
468 (Check-Error wrong-type-argument (<= 'foo 1))
|
|
|
469 (Check-Error wrong-type-argument (>= 'foo 1))
|
|
|
470 (Check-Error wrong-type-argument (< 'foo 1))
|
|
|
471 (Check-Error wrong-type-argument (> 'foo 1))
|
|
|
472 (Check-Error wrong-type-argument (/= 'foo 1))
|
|
|
473
|
|
|
474 ;; Meat
|
|
|
475 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
|
|
398
|
476 (dolist (two '(2 2.0 ?\02))
|
|
384
|
477 (Assert (< one two))
|
|
|
478 (Assert (<= one two))
|
|
|
479 (Assert (<= two two))
|
|
|
480 (Assert (> two one))
|
|
|
481 (Assert (>= two one))
|
|
|
482 (Assert (>= two two))
|
|
|
483 (Assert (/= one two))
|
|
|
484 (Assert (not (/= two two)))
|
|
|
485 (Assert (not (< one one)))
|
|
|
486 (Assert (not (> one one)))
|
|
|
487 (Assert (<= one one two two))
|
|
|
488 (Assert (not (< one one two two)))
|
|
|
489 (Assert (>= two two one one))
|
|
|
490 (Assert (not (> two two one one)))
|
|
|
491 (Assert (= one one one))
|
|
|
492 (Assert (not (= one one one two)))
|
|
|
493 (Assert (not (/= one two one)))
|
|
|
494 ))
|
|
|
495
|
|
|
496 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
|
|
398
|
497 (dolist (two '(2 2.0 ?\02))
|
|
384
|
498 (Assert (< one two))
|
|
|
499 (Assert (<= one two))
|
|
|
500 (Assert (<= two two))
|
|
|
501 (Assert (> two one))
|
|
|
502 (Assert (>= two one))
|
|
|
503 (Assert (>= two two))
|
|
|
504 (Assert (/= one two))
|
|
|
505 (Assert (not (/= two two)))
|
|
|
506 (Assert (not (< one one)))
|
|
|
507 (Assert (not (> one one)))
|
|
|
508 (Assert (<= one one two two))
|
|
|
509 (Assert (not (< one one two two)))
|
|
|
510 (Assert (>= two two one one))
|
|
|
511 (Assert (not (> two two one one)))
|
|
|
512 (Assert (= one one one))
|
|
|
513 (Assert (not (= one one one two)))
|
|
|
514 (Assert (not (/= one two one)))
|
|
|
515 ))
|
|
|
516
|
|
|
517 ;; ad-hoc
|
|
|
518 (Assert (< 1 2))
|
|
|
519 (Assert (< 1 2 3 4 5 6))
|
|
|
520 (Assert (not (< 1 1)))
|
|
|
521 (Assert (not (< 2 1)))
|
|
|
522
|
|
|
523
|
|
|
524 (Assert (not (< 1 1)))
|
|
|
525 (Assert (< 1 2 3 4 5 6))
|
|
|
526 (Assert (<= 1 2 3 4 5 6))
|
|
|
527 (Assert (<= 1 2 3 4 5 6 6))
|
|
|
528 (Assert (not (< 1 2 3 4 5 6 6)))
|
|
|
529 (Assert (<= 1 1))
|
|
|
530
|
|
|
531 (Assert (not (eq (point) (point-marker))))
|
|
|
532 (Assert (= 1 (Int-to-Marker 1)))
|
|
|
533 (Assert (= (point) (point-marker)))
|
|
|
534
|
|
|
535 ;;-----------------------------------------------------
|
|
|
536 ;; testing list-walker functions
|
|
|
537 ;;-----------------------------------------------------
|
|
|
538 (macrolet
|
|
|
539 ((test-fun
|
|
|
540 (fun)
|
|
|
541 `(progn
|
|
|
542 (Check-Error wrong-number-of-arguments (,fun))
|
|
|
543 (Check-Error wrong-number-of-arguments (,fun nil))
|
|
|
544 (Check-Error malformed-list (,fun nil 1))
|
|
398
|
545 ,@(loop for n in '(1 2 2000)
|
|
384
|
546 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
|
|
|
547 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))))
|
|
|
548
|
|
|
549 (test-funs member old-member
|
|
|
550 memq old-memq
|
|
|
551 assoc old-assoc
|
|
|
552 rassoc old-rassoc
|
|
|
553 rassq old-rassq
|
|
|
554 delete old-delete
|
|
|
555 delq old-delq
|
|
|
556 remassoc remassq remrassoc remrassq))
|
|
|
557
|
|
|
558 (let ((x '((1 . 2) 3 (4 . 5))))
|
|
|
559 (Assert (eq (assoc 1 x) (car x)))
|
|
|
560 (Assert (eq (assq 1 x) (car x)))
|
|
|
561 (Assert (eq (rassoc 1 x) nil))
|
|
|
562 (Assert (eq (rassq 1 x) nil))
|
|
|
563 (Assert (eq (assoc 2 x) nil))
|
|
|
564 (Assert (eq (assq 2 x) nil))
|
|
|
565 (Assert (eq (rassoc 2 x) (car x)))
|
|
|
566 (Assert (eq (rassq 2 x) (car x)))
|
|
|
567 (Assert (eq (assoc 3 x) nil))
|
|
|
568 (Assert (eq (assq 3 x) nil))
|
|
|
569 (Assert (eq (rassoc 3 x) nil))
|
|
|
570 (Assert (eq (rassq 3 x) nil))
|
|
|
571 (Assert (eq (assoc 4 x) (caddr x)))
|
|
|
572 (Assert (eq (assq 4 x) (caddr x)))
|
|
|
573 (Assert (eq (rassoc 4 x) nil))
|
|
|
574 (Assert (eq (rassq 4 x) nil))
|
|
|
575 (Assert (eq (assoc 5 x) nil))
|
|
|
576 (Assert (eq (assq 5 x) nil))
|
|
|
577 (Assert (eq (rassoc 5 x) (caddr x)))
|
|
|
578 (Assert (eq (rassq 5 x) (caddr x)))
|
|
|
579 (Assert (eq (assoc 6 x) nil))
|
|
|
580 (Assert (eq (assq 6 x) nil))
|
|
|
581 (Assert (eq (rassoc 6 x) nil))
|
|
|
582 (Assert (eq (rassq 6 x) nil)))
|
|
|
583
|
|
|
584 (let ((x '(("1" . "2") "3" ("4" . "5"))))
|
|
|
585 (Assert (eq (assoc "1" x) (car x)))
|
|
|
586 (Assert (eq (assq "1" x) nil))
|
|
|
587 (Assert (eq (rassoc "1" x) nil))
|
|
|
588 (Assert (eq (rassq "1" x) nil))
|
|
|
589 (Assert (eq (assoc "2" x) nil))
|
|
|
590 (Assert (eq (assq "2" x) nil))
|
|
|
591 (Assert (eq (rassoc "2" x) (car x)))
|
|
|
592 (Assert (eq (rassq "2" x) nil))
|
|
|
593 (Assert (eq (assoc "3" x) nil))
|
|
|
594 (Assert (eq (assq "3" x) nil))
|
|
|
595 (Assert (eq (rassoc "3" x) nil))
|
|
|
596 (Assert (eq (rassq "3" x) nil))
|
|
|
597 (Assert (eq (assoc "4" x) (caddr x)))
|
|
|
598 (Assert (eq (assq "4" x) nil))
|
|
|
599 (Assert (eq (rassoc "4" x) nil))
|
|
|
600 (Assert (eq (rassq "4" x) nil))
|
|
|
601 (Assert (eq (assoc "5" x) nil))
|
|
|
602 (Assert (eq (assq "5" x) nil))
|
|
|
603 (Assert (eq (rassoc "5" x) (caddr x)))
|
|
|
604 (Assert (eq (rassq "5" x) nil))
|
|
|
605 (Assert (eq (assoc "6" x) nil))
|
|
|
606 (Assert (eq (assq "6" x) nil))
|
|
|
607 (Assert (eq (rassoc "6" x) nil))
|
|
|
608 (Assert (eq (rassq "6" x) nil)))
|
|
|
609
|
|
|
610 (flet ((a () (list '(1 . 2) 3 '(4 . 5))))
|
|
|
611 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
|
|
|
612 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
|
|
|
613 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a)))))
|
|
|
614 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a)))))
|
|
|
615
|
|
|
616 (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a)))))
|
|
|
617 (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a)))))
|
|
|
618 (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
|
|
|
619 (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
|
|
|
620
|
|
|
621 (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a)))))
|
|
|
622 (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a)))))
|
|
|
623 (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a)))))
|
|
|
624 (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a)))))
|
|
|
625
|
|
|
626 (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
|
|
|
627 (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
|
|
|
628 (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a)))))
|
|
|
629 (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a)))))
|
|
|
630
|
|
|
631 (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a)))))
|
|
|
632 (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a)))))
|
|
|
633 (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
|
|
|
634 (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
|
|
|
635
|
|
|
636 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a)))))
|
|
|
637 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a)))))
|
|
|
638 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a)))))
|
|
|
639 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a)))))
|
|
|
640
|
|
|
641 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
|
|
|
642 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
|
|
|
643 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
|
|
|
644 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
|
|
|
645
|
|
|
646 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
|
|
|
647 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
|
|
|
648 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
|
|
|
649 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
|
|
|
650 )
|
|
|
651
|
|
|
652
|
|
|
653
|
|
|
654 (flet ((a () (list '("1" . "2") "3" '("4" . "5"))))
|
|
|
655 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
|
|
|
656 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a)))))
|
|
|
657 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a)))))
|
|
|
658 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a)))))
|
|
|
659
|
|
|
660 (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a)))))
|
|
|
661 (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a)))))
|
|
|
662 (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
|
|
|
663 (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a)))))
|
|
|
664
|
|
|
665 (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a)))))
|
|
|
666 (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a)))))
|
|
|
667 (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a)))))
|
|
|
668 (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a)))))
|
|
|
669
|
|
|
670 (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
|
|
|
671 (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a)))))
|
|
|
672 (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a)))))
|
|
|
673 (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a)))))
|
|
|
674
|
|
|
675 (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a)))))
|
|
|
676 (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a)))))
|
|
|
677 (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
|
|
|
678 (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a)))))
|
|
|
679
|
|
|
680 (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a)))))
|
|
|
681 (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a)))))
|
|
|
682 (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a)))))
|
|
|
683 (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a))))))
|
|
|
684
|
|
|
685 ;;-----------------------------------------------------
|
|
|
686 ;; function-max-args, function-min-args
|
|
|
687 ;;-----------------------------------------------------
|
|
|
688 (defmacro check-function-argcounts (fun min max)
|
|
|
689 `(progn
|
|
|
690 (Assert (eq (function-min-args ,fun) ,min))
|
|
|
691 (Assert (eq (function-max-args ,fun) ,max))))
|
|
|
692
|
|
|
693 (check-function-argcounts 'prog1 1 nil) ; special form
|
|
|
694 (check-function-argcounts 'command-execute 1 3) ; normal subr
|
|
|
695 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr
|
|
|
696 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
|
|
|
697
|
|
|
698 ;; Test interpreted and compiled functions
|
|
|
699 (loop for (arglist min max) in
|
|
|
700 '(((arg1 arg2 &rest args) 2 nil)
|
|
|
701 ((arg1 arg2 &optional arg3 arg4) 2 4)
|
|
|
702 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil)
|
|
|
703 (() 0 0))
|
|
|
704 do
|
|
|
705 (eval
|
|
|
706 `(progn
|
|
|
707 (defun test-fun ,arglist nil)
|
|
|
708 (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
|
|
|
709 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
|
|
|
710
|
|
|
711 ;;-----------------------------------------------------
|
|
|
712 ;; Detection of cyclic variable indirection loops
|
|
|
713 ;;-----------------------------------------------------
|
|
|
714 (fset 'test-sym1 'test-sym1)
|
|
|
715 (Check-Error cyclic-function-indirection (test-sym1))
|
|
|
716
|
|
|
717 (fset 'test-sym1 'test-sym2)
|
|
|
718 (fset 'test-sym2 'test-sym1)
|
|
|
719 (Check-Error cyclic-function-indirection (test-sym1))
|
|
|
720 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops!
|
|
|
721 (fmakunbound 'test-sym2)
|
|
|
722
|
|
|
723 ;;-----------------------------------------------------
|
|
|
724 ;; Test `type-of'
|
|
|
725 ;;-----------------------------------------------------
|
|
|
726 (Assert (eq (type-of load-path) 'cons))
|
|
|
727 (Assert (eq (type-of obarray) 'vector))
|
|
|
728 (Assert (eq (type-of 42) 'integer))
|
|
|
729 (Assert (eq (type-of ?z) 'character))
|
|
|
730 (Assert (eq (type-of "42") 'string))
|
|
|
731 (Assert (eq (type-of 'foo) 'symbol))
|
|
|
732 (Assert (eq (type-of (selected-device)) 'device))
|
|
|
733
|
|
|
734 ;;-----------------------------------------------------
|
|
|
735 ;; Test mapping functions
|
|
|
736 ;;-----------------------------------------------------
|
|
|
737 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer)))
|
|
|
738 (Assert (equal (mapcar #'identity load-path) load-path))
|
|
|
739 (Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3)))
|
|
|
740 (Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3)))
|
|
|
741 (Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3)))
|
|
|
742 (Assert (equal (mapcar #'identity #*010) '(0 1 0)))
|
|
|
743
|
|
|
744 (let ((z 0) (list (make-list 1000 1)))
|
|
|
745 (mapc (lambda (x) (incf z x)) list)
|
|
|
746 (Assert (eq 1000 z)))
|
|
|
747
|
|
|
748 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer)))
|
|
|
749 (Assert (equal (mapvector #'identity '(1 2 3)) [1 2 3]))
|
|
|
750 (Assert (equal (mapvector #'identity "123") [?1 ?2 ?3]))
|
|
|
751 (Assert (equal (mapvector #'identity [1 2 3]) [1 2 3]))
|
|
|
752 (Assert (equal (mapvector #'identity #*010) [0 1 0]))
|
|
|
753
|
|
|
754 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo"))
|
|
|
755 (Assert (equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3"))
|
|
|
756 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3"))
|
|
|
757
|
|
398
|
758 ;; The following 2 functions used to crash XEmacs via mapcar1().
|
|
|
759 ;; We don't test the actual values of the mapcar, since they're undefined.
|
|
|
760 (Assert
|
|
|
761 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
|
|
|
762 (mapcar
|
|
|
763 (lambda (y)
|
|
|
764 "Devious evil mapping function"
|
|
|
765 (when (eq (car y) 2) ; go out onto a limb
|
|
|
766 (setcdr x nil) ; cut it off behind us
|
|
|
767 (garbage-collect)) ; are we riding a magic broomstick?
|
|
|
768 (car y)) ; sorry, hard landing
|
|
|
769 x)))
|
|
|
770
|
|
|
771 (Assert
|
|
|
772 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
|
|
|
773 (mapcar
|
|
|
774 (lambda (y)
|
|
|
775 "Devious evil mapping function"
|
|
|
776 (when (eq (car y) 1)
|
|
|
777 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway
|
|
|
778 (car y))
|
|
|
779 x)))
|
|
|
780
|
|
384
|
781 ;;-----------------------------------------------------
|
|
|
782 ;; Test vector functions
|
|
|
783 ;;-----------------------------------------------------
|
|
|
784 (Assert (equal [1 2 3] [1 2 3]))
|
|
|
785 (Assert (equal [] []))
|
|
|
786 (Assert (not (equal [1 2 3] [])))
|
|
|
787 (Assert (not (equal [1 2 3] [1 2 4])))
|
|
|
788 (Assert (not (equal [0 2 3] [1 2 3])))
|
|
|
789 (Assert (not (equal [1 2 3] [1 2 3 4])))
|
|
|
790 (Assert (not (equal [1 2 3 4] [1 2 3])))
|
|
|
791 (Assert (equal (vector 1 2 3) [1 2 3]))
|
|
|
792 (Assert (equal (make-vector 3 1) [1 1 1]))
|
|
|
793
|
|
|
794 ;;-----------------------------------------------------
|
|
|
795 ;; Test bit-vector functions
|
|
|
796 ;;-----------------------------------------------------
|
|
|
797 (Assert (equal #*010 #*010))
|
|
|
798 (Assert (equal #* #*))
|
|
|
799 (Assert (not (equal #*010 #*011)))
|
|
|
800 (Assert (not (equal #*010 #*)))
|
|
|
801 (Assert (not (equal #*110 #*010)))
|
|
|
802 (Assert (not (equal #*010 #*0100)))
|
|
|
803 (Assert (not (equal #*0101 #*010)))
|
|
|
804 (Assert (equal (bit-vector 0 1 0) #*010))
|
|
|
805 (Assert (equal (make-bit-vector 3 1) #*111))
|
|
|
806 (Assert (equal (make-bit-vector 3 0) #*000))
|
|
388
|
807
|
|
|
808 ;;-----------------------------------------------------
|
|
|
809 ;; Test buffer-local variables used as (ugh!) function parameters
|
|
|
810 ;;-----------------------------------------------------
|
|
|
811 (make-local-variable 'test-emacs-buffer-local-variable)
|
|
|
812 (byte-compile
|
|
|
813 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable)
|
|
|
814 (setq test-emacs-buffer-local-variable nil)))
|
|
|
815 (test-emacs-buffer-local-parameter nil)
|
|
398
|
816
|
|
|
817 ;;-----------------------------------------------------
|
|
|
818 ;; Test split-string
|
|
|
819 ;;-----------------------------------------------------
|
|
|
820 ;; Hrvoje didn't like these tests so I'm disabling them for now. -sb
|
|
|
821 ;(Assert (equal (split-string "foo" "") '("" "f" "o" "o" "")))
|
|
|
822 ;(Assert (equal (split-string "foo" "^") '("" "foo")))
|
|
|
823 ;(Assert (equal (split-string "foo" "$") '("foo" "")))
|
|
|
824 (Assert (equal (split-string "foo,bar" ",") '("foo" "bar")))
|
|
|
825 (Assert (equal (split-string ",foo,bar," ",") '("" "foo" "bar" "")))
|
|
|
826 (Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,")))
|
|
|
827 (Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" "")))
|
|
|
828 (Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" "")))
|
|
|
829 (Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar")))
|
|
|
830 (Assert (equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" "")))
|
|
|
831 (Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar")))
|
|
|
832 (Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")))
|
|
|
833
|
|
|
834 ;;-----------------------------------------------------
|
|
|
835 ;; Test near-text buffer functions.
|
|
|
836 ;;-----------------------------------------------------
|
|
|
837 (with-temp-buffer
|
|
|
838 (erase-buffer)
|
|
|
839 (Assert (eq (char-before) nil))
|
|
|
840 (Assert (eq (char-before (point)) nil))
|
|
|
841 (Assert (eq (char-before (point-marker)) nil))
|
|
|
842 (Assert (eq (char-before (point) (current-buffer)) nil))
|
|
|
843 (Assert (eq (char-before (point-marker) (current-buffer)) nil))
|
|
|
844 (Assert (eq (char-after) nil))
|
|
|
845 (Assert (eq (char-after (point)) nil))
|
|
|
846 (Assert (eq (char-after (point-marker)) nil))
|
|
|
847 (Assert (eq (char-after (point) (current-buffer)) nil))
|
|
|
848 (Assert (eq (char-after (point-marker) (current-buffer)) nil))
|
|
|
849 (Assert (eq (preceding-char) 0))
|
|
|
850 (Assert (eq (preceding-char (current-buffer)) 0))
|
|
|
851 (Assert (eq (following-char) 0))
|
|
|
852 (Assert (eq (following-char (current-buffer)) 0))
|
|
|
853 (insert "foobar")
|
|
|
854 (Assert (eq (char-before) ?r))
|
|
|
855 (Assert (eq (char-after) nil))
|
|
|
856 (Assert (eq (preceding-char) ?r))
|
|
|
857 (Assert (eq (following-char) 0))
|
|
|
858 (goto-char (point-min))
|
|
|
859 (Assert (eq (char-before) nil))
|
|
|
860 (Assert (eq (char-after) ?f))
|
|
|
861 (Assert (eq (preceding-char) 0))
|
|
|
862 (Assert (eq (following-char) ?f))
|
|
|
863 )
|
|
|
864
|
|
|
865 ;;-----------------------------------------------------
|
|
|
866 ;; Test plist manipulation functions.
|
|
|
867 ;;-----------------------------------------------------
|
|
|
868 (let ((sym (make-symbol "test-symbol")))
|
|
|
869 (Assert (eq t (get* sym t t)))
|
|
|
870 (Assert (eq t (get sym t t)))
|
|
|
871 (Assert (eq t (getf nil t t)))
|
|
|
872 (Assert (eq t (plist-get nil t t)))
|
|
|
873 (put sym 'bar 'baz)
|
|
|
874 (Assert (eq 'baz (get sym 'bar)))
|
|
|
875 (Assert (eq 'baz (getf '(bar baz) 'bar)))
|
|
|
876 (Assert (eq 'baz (getf (symbol-plist sym) 'bar)))
|
|
|
877 (Assert (eq 2 (getf '(1 2) 1)))
|
|
|
878 (Assert (eq 4 (put sym 3 4)))
|
|
|
879 (Assert (eq 4 (get sym 3)))
|
|
|
880 (Assert (eq t (remprop sym 3)))
|
|
|
881 (Assert (eq nil (remprop sym 3)))
|
|
|
882 (Assert (eq 5 (get sym 3 5)))
|
|
|
883 )
|
|
|
884
|
|
|
885 (loop for obj in
|
|
|
886 (list (make-symbol "test-symbol")
|
|
|
887 "test-string"
|
|
|
888 (make-extent nil nil nil)
|
|
|
889 (make-face 'test-face))
|
|
|
890 do
|
|
|
891 (Assert (eq 2 (get obj ?1 2)))
|
|
|
892 (Assert (eq 4 (put obj ?3 4)))
|
|
|
893 (Assert (eq 4 (get obj ?3)))
|
|
|
894 (when (or (stringp obj) (symbolp obj))
|
|
|
895 (Assert (equal '(?3 4) (object-plist obj))))
|
|
|
896 (Assert (eq t (remprop obj ?3)))
|
|
|
897 (when (or (stringp obj) (symbolp obj))
|
|
|
898 (Assert (eq '() (object-plist obj))))
|
|
|
899 (Assert (eq nil (remprop obj ?3)))
|
|
|
900 (when (or (stringp obj) (symbolp obj))
|
|
|
901 (Assert (eq '() (object-plist obj))))
|
|
|
902 (Assert (eq 5 (get obj ?3 5)))
|
|
|
903 )
|
|
|
904
|
|
|
905 (Check-Error-Message
|
|
|
906 error "Object type has no properties"
|
|
|
907 (get 2 'property))
|
|
|
908
|
|
|
909 (Check-Error-Message
|
|
|
910 error "Object type has no settable properties"
|
|
|
911 (put (current-buffer) 'property 'value))
|
|
|
912
|
|
|
913 (Check-Error-Message
|
|
|
914 error "Object type has no removable properties"
|
|
|
915 (remprop ?3 'property))
|
|
|
916
|
|
|
917 (Check-Error-Message
|
|
|
918 error "Object type has no properties"
|
|
|
919 (object-plist (symbol-function 'car)))
|
|
|
920
|
|
|
921 (Check-Error-Message
|
|
|
922 error "Can't remove property from object"
|
|
|
923 (remprop (make-extent nil nil nil) 'detachable))
|
|
|
924
|
|
|
925 ;;-----------------------------------------------------
|
|
|
926 ;; Test subseq
|
|
|
927 ;;-----------------------------------------------------
|
|
|
928 (Assert (equal (subseq nil 0) nil))
|
|
|
929 (Assert (equal (subseq [1 2 3] 0) [1 2 3]))
|
|
|
930 (Assert (equal (subseq [1 2 3] 1 -1) [2]))
|
|
|
931 (Assert (equal (subseq "123" 0) "123"))
|
|
|
932 (Assert (equal (subseq "1234" -3 -1) "23"))
|
|
|
933 (Assert (equal (subseq #*0011 0) #*0011))
|
|
|
934 (Assert (equal (subseq #*0011 -3 3) #*01))
|
|
|
935 (Assert (equal (subseq '(1 2 3) 0) '(1 2 3)))
|
|
|
936 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)))
|
|
|
937
|
|
|
938 (Check-Error 'wrong-type-argument (subseq 3 2))
|
|
|
939 (Check-Error 'args-out-of-range (subseq [1 2 3] -42))
|
|
|
940 (Check-Error 'args-out-of-range (subseq [1 2 3] 0 42))
|
