comparison tests/automated/lisp-tests.el @ 4855:189fb67ca31a

Create Assert-eq, Assert-equal, etc. These are equivalent to (Assert (eq ...)) but display both the actual value and the expected value of the comparison. Use them throughout the test suite.
author Ben Wing <ben@xemacs.org>
date Thu, 14 Jan 2010 02:18:03 -0600
parents 084056f46755
children 6772ce4d982b
comparison
equal deleted inserted replaced
4854:95c4ced5c07c 4855:189fb67ca31a
40 40
41 (Check-Error wrong-number-of-arguments (setq setq-test-foo)) 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)) 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)) 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)) 44 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar))
45 (Assert (eq (setq) nil)) 45 (Assert-eq (setq) nil)
46 (Assert (eq (setq-default) nil)) 46 (Assert-eq (setq-default) nil)
47 (Assert (eq (setq setq-test-foo 42) 42)) 47 (Assert-eq (setq setq-test-foo 42) 42)
48 (Assert (eq (setq-default 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)) 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)) 50 (Assert-eq (setq-default setq-test-foo 42 setq-test-bar 99) 99)
51 51
52 (macrolet ((test-setq (expected-result &rest body) 52 (macrolet ((test-setq (expected-result &rest body)
53 `(progn 53 `(progn
54 (defun test-setq-fun () ,@body) 54 (defun test-setq-fun () ,@body)
55 (Assert (eq ,expected-result (test-setq-fun))) 55 (Assert-eq ,expected-result (test-setq-fun))
56 (byte-compile 'test-setq-fun) 56 (byte-compile 'test-setq-fun)
57 (Assert (eq ,expected-result (test-setq-fun)))))) 57 (Assert-eq ,expected-result (test-setq-fun)))))
58 (test-setq nil (setq)) 58 (test-setq nil (setq))
59 (test-setq nil (setq-default)) 59 (test-setq nil (setq-default))
60 (test-setq 42 (setq test-setq-var 42)) 60 (test-setq 42 (setq test-setq-var 42))
61 (test-setq 42 (setq-default 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)) 62 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42))
67 (my-bit-vector (bit-vector 1 0 1 0)) 67 (my-bit-vector (bit-vector 1 0 1 0))
68 (my-string "1234") 68 (my-string "1234")
69 (my-list '(1 2 3 4))) 69 (my-list '(1 2 3 4)))
70 70
71 ;;(Assert (fooooo)) ;; Generate Other failure 71 ;;(Assert (fooooo)) ;; Generate Other failure
72 ;;(Assert (eq 1 2)) ;; Generate Assertion failure 72 ;;(Assert-eq 1 2) ;; Generate Assertion failure
73 73
74 (dolist (sequence (list my-vector my-bit-vector my-string my-list)) 74 (dolist (sequence (list my-vector my-bit-vector my-string my-list))
75 (Assert (sequencep sequence)) 75 (Assert (sequencep sequence))
76 (Assert (eq 4 (length sequence)))) 76 (Assert-eq 4 (length sequence)))
77 77
78 (dolist (array (list my-vector my-bit-vector my-string)) 78 (dolist (array (list my-vector my-bit-vector my-string))
79 (Assert (arrayp array))) 79 (Assert (arrayp array)))
80 80
81 (Assert (eq (elt my-vector 0) 1)) 81 (Assert-eq (elt my-vector 0) 1)
82 (Assert (eq (elt my-bit-vector 0) 1)) 82 (Assert-eq (elt my-bit-vector 0) 1)
83 (Assert (eq (elt my-string 0) ?1)) 83 (Assert-eq (elt my-string 0) ?1)
84 (Assert (eq (elt my-list 0) 1)) 84 (Assert-eq (elt my-list 0) 1)
85 85
86 (fillarray my-vector 5) 86 (fillarray my-vector 5)
87 (fillarray my-bit-vector 1) 87 (fillarray my-bit-vector 1)
88 (fillarray my-string ?5) 88 (fillarray my-string ?5)
89 89
90 (dolist (array (list my-vector my-bit-vector)) 90 (dolist (array (list my-vector my-bit-vector))
91 (Assert (eq 4 (length array)))) 91 (Assert-eq 4 (length array)))
92 92
93 (Assert (eq (elt my-vector 0) 5)) 93 (Assert-eq (elt my-vector 0) 5)
94 (Assert (eq (elt my-bit-vector 0) 1)) 94 (Assert-eq (elt my-bit-vector 0) 1)
95 (Assert (eq (elt my-string 0) ?5)) 95 (Assert-eq (elt my-string 0) ?5)
96 96
97 (Assert (eq (elt my-vector 3) 5)) 97 (Assert-eq (elt my-vector 3) 5)
98 (Assert (eq (elt my-bit-vector 3) 1)) 98 (Assert-eq (elt my-bit-vector 3) 1)
99 (Assert (eq (elt my-string 3) ?5)) 99 (Assert-eq (elt my-string 3) ?5)
100 100
101 (fillarray my-bit-vector 0) 101 (fillarray my-bit-vector 0)
102 (Assert (eq 4 (length my-bit-vector))) 102 (Assert-eq 4 (length my-bit-vector))
103 (Assert (eq (elt my-bit-vector 2) 0)) 103 (Assert-eq (elt my-bit-vector 2) 0)
104 ) 104 )
105 105
106 (defun make-circular-list (length) 106 (defun make-circular-list (length)
107 "Create evil emacs-crashing circular list of length LENGTH" 107 "Create evil emacs-crashing circular list of length LENGTH"
108 (let ((circular-list 108 (let ((circular-list
122 (dolist (length '(1 2 3 4 1000 2000)) 122 (dolist (length '(1 2 3 4 1000 2000))
123 (Check-Error circular-list (nconc (make-circular-list length) 'foo)) 123 (Check-Error circular-list (nconc (make-circular-list length) 'foo))
124 (Check-Error circular-list (nconc '(1 . 2) (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))) 125 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo)))
126 126
127 (Assert (eq (nconc) nil)) 127 (Assert-eq (nconc) nil)
128 (Assert (eq (nconc nil) nil)) 128 (Assert-eq (nconc nil) nil)
129 (Assert (eq (nconc nil nil) nil)) 129 (Assert-eq (nconc nil nil) nil)
130 (Assert (eq (nconc nil nil nil) nil)) 130 (Assert-eq (nconc nil nil nil) nil)
131 131
132 (let ((x (make-list-012))) (Assert (eq (nconc nil x) x))) 132 (let ((x (make-list-012))) (Assert-eq (nconc nil x) x))
133 (let ((x (make-list-012))) (Assert (eq (nconc x nil) 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))) 134 (let ((x (make-list-012))) (Assert-eq (nconc nil x nil) x))
135 (let ((x (make-list-012))) (Assert (eq (nconc x) 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))) 136 (let ((x (make-list-012))) (Assert-eq (nconc x (make-circular-list 3)) x))
137 137
138 (Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6))) 138 (Assert-equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6))
139 139
140 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) 140 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil)))
141 (Assert (eq (length y) 6)) 141 (Assert-eq (length y) 6)
142 (Assert (eq (nth 3 y) 3))) 142 (Assert-eq (nth 3 y) 3))
143 143
144 ;;----------------------------------------------------- 144 ;;-----------------------------------------------------
145 ;; Test `last' 145 ;; Test `last'
146 ;;----------------------------------------------------- 146 ;;-----------------------------------------------------
147 (Check-Error wrong-type-argument (last 'foo)) 147 (Check-Error wrong-type-argument (last 'foo))
148 (Check-Error wrong-number-of-arguments (last)) 148 (Check-Error wrong-number-of-arguments (last))
149 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1)) 149 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1))
150 (Check-Error circular-list (last (make-circular-list 1))) 150 (Check-Error circular-list (last (make-circular-list 1)))
151 (Check-Error circular-list (last (make-circular-list 2000))) 151 (Check-Error circular-list (last (make-circular-list 2000)))
152 (let ((x (list 0 1 2 3))) 152 (let ((x (list 0 1 2 3)))
153 (Assert (eq (last nil) nil)) 153 (Assert-eq (last nil) nil)
154 (Assert (eq (last x 0) nil)) 154 (Assert-eq (last x 0) nil)
155 (Assert (eq (last x ) (cdddr x))) 155 (Assert-eq (last x ) (cdddr x))
156 (Assert (eq (last x 1) (cdddr x))) 156 (Assert-eq (last x 1) (cdddr x))
157 (Assert (eq (last x 2) (cddr x))) 157 (Assert-eq (last x 2) (cddr x))
158 (Assert (eq (last x 3) (cdr x))) 158 (Assert-eq (last x 3) (cdr x))
159 (Assert (eq (last x 4) x)) 159 (Assert-eq (last x 4) x)
160 (Assert (eq (last x 9) x)) 160 (Assert-eq (last x 9) x)
161 (Assert (eq (last '(1 . 2) 0) 2)) 161 (Assert-eq (last '(1 . 2) 0) 2)
162 ) 162 )
163 163
164 ;;----------------------------------------------------- 164 ;;-----------------------------------------------------
165 ;; Test `butlast' and `nbutlast' 165 ;; Test `butlast' and `nbutlast'
166 ;;----------------------------------------------------- 166 ;;-----------------------------------------------------
176 (Check-Error circular-list (nbutlast (make-circular-list 2000))) 176 (Check-Error circular-list (nbutlast (make-circular-list 2000)))
177 177
178 (let* ((x (list 0 1 2 3)) 178 (let* ((x (list 0 1 2 3))
179 (y (butlast x)) 179 (y (butlast x))
180 (z (nbutlast x))) 180 (z (nbutlast x)))
181 (Assert (eq z x)) 181 (Assert-eq z x)
182 (Assert (not (eq y x))) 182 (Assert (not (eq y x)))
183 (Assert (equal y '(0 1 2))) 183 (Assert-equal y '(0 1 2))
184 (Assert (equal z y))) 184 (Assert-equal z y))
185 185
186 (let* ((x (list 0 1 2 3 4)) 186 (let* ((x (list 0 1 2 3 4))
187 (y (butlast x 2)) 187 (y (butlast x 2))
188 (z (nbutlast x 2))) 188 (z (nbutlast x 2)))
189 (Assert (eq z x)) 189 (Assert-eq z x)
190 (Assert (not (eq y x))) 190 (Assert (not (eq y x)))
191 (Assert (equal y '(0 1 2))) 191 (Assert-equal y '(0 1 2))
192 (Assert (equal z y))) 192 (Assert-equal z y))
193 193
194 (let* ((x (list 0 1 2 3)) 194 (let* ((x (list 0 1 2 3))
195 (y (butlast x 0)) 195 (y (butlast x 0))
196 (z (nbutlast x 0))) 196 (z (nbutlast x 0)))
197 (Assert (eq z x)) 197 (Assert-eq z x)
198 (Assert (not (eq y x))) 198 (Assert (not (eq y x)))
199 (Assert (equal y '(0 1 2 3))) 199 (Assert-equal y '(0 1 2 3))
200 (Assert (equal z y))) 200 (Assert-equal z y))
201 201
202 (Assert (eq (butlast '(x)) nil)) 202 (Assert-eq (butlast '(x)) nil)
203 (Assert (eq (nbutlast '(x)) nil)) 203 (Assert-eq (nbutlast '(x)) nil)
204 (Assert (eq (butlast '()) nil)) 204 (Assert-eq (butlast '()) nil)
205 (Assert (eq (nbutlast '()) nil)) 205 (Assert-eq (nbutlast '()) nil)
206 206
207 ;;----------------------------------------------------- 207 ;;-----------------------------------------------------
208 ;; Test `copy-list' 208 ;; Test `copy-list'
209 ;;----------------------------------------------------- 209 ;;-----------------------------------------------------
210 (Check-Error wrong-type-argument (copy-list 'foo)) 210 (Check-Error wrong-type-argument (copy-list 'foo))
211 (Check-Error wrong-number-of-arguments (copy-list)) 211 (Check-Error wrong-number-of-arguments (copy-list))
212 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) 212 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1))
213 (Check-Error circular-list (copy-list (make-circular-list 1))) 213 (Check-Error circular-list (copy-list (make-circular-list 1)))
214 (Check-Error circular-list (copy-list (make-circular-list 2000))) 214 (Check-Error circular-list (copy-list (make-circular-list 2000)))
215 (Assert (eq '() (copy-list '()))) 215 (Assert-eq '() (copy-list '()))
216 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) 216 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
217 (let ((y (copy-list x))) 217 (let ((y (copy-list x)))
218 (Assert (and (equal x y) (not (eq x y)))))) 218 (Assert (and (equal x y) (not (eq x y))))))
219 219
220 ;;----------------------------------------------------- 220 ;;-----------------------------------------------------
221 ;; Arithmetic operations 221 ;; Arithmetic operations
222 ;;----------------------------------------------------- 222 ;;-----------------------------------------------------
223 223
224 ;; Test `+' 224 ;; Test `+'
225 (Assert (eq (+ 1 1) 2)) 225 (Assert-eq (+ 1 1) 2)
226 (Assert (= (+ 1.0 1.0) 2.0)) 226 (Assert= (+ 1.0 1.0) 2.0)
227 (Assert (= (+ 1.0 3.0 0.0) 4.0)) 227 (Assert= (+ 1.0 3.0 0.0) 4.0)
228 (Assert (= (+ 1 1.0) 2.0)) 228 (Assert= (+ 1 1.0) 2.0)
229 (Assert (= (+ 1.0 1) 2.0)) 229 (Assert= (+ 1.0 1) 2.0)
230 (Assert (= (+ 1.0 1 1) 3.0)) 230 (Assert= (+ 1.0 1 1) 3.0)
231 (Assert (= (+ 1 1 1.0) 3.0)) 231 (Assert= (+ 1 1 1.0) 3.0)
232 (if (featurep 'bignum) 232 (if (featurep 'bignum)
233 (progn 233 (progn
234 (Assert (bignump (1+ most-positive-fixnum))) 234 (Assert (bignump (1+ most-positive-fixnum)))
235 (Assert (eq most-positive-fixnum (1- (1+ most-positive-fixnum)))) 235 (Assert-eq most-positive-fixnum (1- (1+ most-positive-fixnum)))
236 (Assert (bignump (+ most-positive-fixnum 1))) 236 (Assert (bignump (+ most-positive-fixnum 1)))
237 (Assert (eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1))) 237 (Assert-eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1))
238 (Assert (= (1+ most-positive-fixnum) (- most-negative-fixnum))) 238 (Assert= (1+ most-positive-fixnum) (- most-negative-fixnum))
239 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum) 239 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum)
240 3)))) 240 3))))
241 (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum)) 241 (Assert-eq (1+ most-positive-fixnum) most-negative-fixnum)
242 (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum))) 242 (Assert-eq (+ most-positive-fixnum 1) most-negative-fixnum))
243 243
244 (when (featurep 'ratio) 244 (when (featurep 'ratio)
245 (let ((threefourths (read "3/4")) 245 (let ((threefourths (read "3/4"))
246 (threehalfs (read "3/2")) 246 (threehalfs (read "3/2"))
247 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) 247 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
248 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum)) 248 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum))
249 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) 249 (negone (div (1+ most-positive-fixnum) most-negative-fixnum)))
250 (Assert (= negone -1)) 250 (Assert= negone -1)
251 (Assert (= threehalfs (+ threefourths threefourths))) 251 (Assert= threehalfs (+ threefourths threefourths))
252 (Assert (zerop (+ bigpos bigneg))))) 252 (Assert (zerop (+ bigpos bigneg)))))
253 253
254 ;; Test `-' 254 ;; Test `-'
255 (Check-Error wrong-number-of-arguments (-)) 255 (Check-Error wrong-number-of-arguments (-))
256 (Assert (eq (- 0) 0)) 256 (Assert-eq (- 0) 0)
257 (Assert (eq (- 1) -1)) 257 (Assert-eq (- 1) -1)
258 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) 258 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1)))
259 (Assert (= (+ 1 one) 2)) 259 (Assert= (+ 1 one) 2)
260 (Assert (= (+ one) 1)) 260 (Assert= (+ one) 1)
261 (Assert (= (+ one) one)) 261 (Assert= (+ one) one)
262 (Assert (= (- one) -1)) 262 (Assert= (- one) -1)
263 (Assert (= (- one one) 0)) 263 (Assert= (- one one) 0)
264 (Assert (= (- one one one) -1)) 264 (Assert= (- one one one) -1)
265 (Assert (= (- 0 one) -1)) 265 (Assert= (- 0 one) -1)
266 (Assert (= (- 0 one one) -2)) 266 (Assert= (- 0 one one) -2)
267 (Assert (= (+ one 1) 2)) 267 (Assert= (+ one 1) 2)
268 (dolist (zero '(0 0.0 ?\0)) 268 (dolist (zero '(0 0.0 ?\0))
269 (Assert (= (+ 1 zero) 1) zero) 269 (Assert= (+ 1 zero) 1 zero)
270 (Assert (= (+ zero 1) 1) zero) 270 (Assert= (+ zero 1) 1 zero)
271 (Assert (= (- zero) zero) zero) 271 (Assert= (- zero) zero zero)
272 (Assert (= (- zero) 0) zero) 272 (Assert= (- zero) 0 zero)
273 (Assert (= (- zero zero) 0) zero) 273 (Assert= (- zero zero) 0 zero)
274 (Assert (= (- zero one one) -2) zero))) 274 (Assert= (- zero one one) -2 zero)))
275 275
276 (Assert (= (- 1.5 1) .5)) 276 (Assert= (- 1.5 1) .5)
277 (Assert (= (- 1 1.5) (- .5))) 277 (Assert= (- 1 1.5) (- .5))
278 278
279 (if (featurep 'bignum) 279 (if (featurep 'bignum)
280 (progn 280 (progn
281 (Assert (bignump (1- most-negative-fixnum))) 281 (Assert (bignump (1- most-negative-fixnum)))
282 (Assert (eq most-negative-fixnum (1+ (1- most-negative-fixnum)))) 282 (Assert-eq most-negative-fixnum (1+ (1- most-negative-fixnum)))
283 (Assert (bignump (- most-negative-fixnum 1))) 283 (Assert (bignump (- most-negative-fixnum 1)))
284 (Assert (eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1))) 284 (Assert-eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1))
285 (Assert (= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2))) 285 (Assert= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2))
286 (Assert (eq (- (- most-positive-fixnum most-negative-fixnum) 286 (Assert-eq (- (- most-positive-fixnum most-negative-fixnum)
287 (* 2 most-positive-fixnum)) 287 (* 2 most-positive-fixnum))
288 1))) 288 1))
289 (Assert (eq (1- most-negative-fixnum) most-positive-fixnum)) 289 (Assert-eq (1- most-negative-fixnum) most-positive-fixnum)
290 (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum))) 290 (Assert-eq (- most-negative-fixnum 1) most-positive-fixnum))
291 291
292 (when (featurep 'ratio) 292 (when (featurep 'ratio)
293 (let ((threefourths (read "3/4")) 293 (let ((threefourths (read "3/4"))
294 (threehalfs (read "3/2")) 294 (threehalfs (read "3/2"))
295 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) 295 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
296 (bigneg (div most-positive-fixnum most-negative-fixnum)) 296 (bigneg (div most-positive-fixnum most-negative-fixnum))
297 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) 297 (negone (div (1+ most-positive-fixnum) most-negative-fixnum)))
298 (Assert (= (- negone) 1)) 298 (Assert= (- negone) 1)
299 (Assert (= threefourths (- threehalfs threefourths))) 299 (Assert= threefourths (- threehalfs threefourths))
300 (Assert (= (- bigpos bigneg) 2)))) 300 (Assert= (- bigpos bigneg) 2)))
301 301
302 ;; Test `/' 302 ;; Test `/'
303 303
304 ;; Test division by zero errors 304 ;; Test division by zero errors
305 (dolist (zero '(0 0.0 ?\0)) 305 (dolist (zero '(0 0.0 ?\0))
310 (Check-Error arith-error (/ n1 n2 zero))))) 310 (Check-Error arith-error (/ n1 n2 zero)))))
311 311
312 ;; Other tests for `/' 312 ;; Other tests for `/'
313 (Check-Error wrong-number-of-arguments (/)) 313 (Check-Error wrong-number-of-arguments (/))
314 (let (x) 314 (let (x)
315 (Assert (= (/ (setq x 2)) 0)) 315 (Assert= (/ (setq x 2)) 0)
316 (Assert (= (/ (setq x 2.0)) 0.5))) 316 (Assert= (/ (setq x 2.0)) 0.5))
317 317
318 (dolist (six '(6 6.0 ?\06)) 318 (dolist (six '(6 6.0 ?\06))
319 (dolist (two '(2 2.0 ?\02)) 319 (dolist (two '(2 2.0 ?\02))
320 (dolist (three '(3 3.0 ?\03)) 320 (dolist (three '(3 3.0 ?\03))
321 (Assert (= (/ six two) three) (list six two three))))) 321 (Assert= (/ six two) three (list six two three)))))
322 322
323 (dolist (three '(3 3.0 ?\03)) 323 (dolist (three '(3 3.0 ?\03))
324 (Assert (= (/ three 2.0) 1.5) three)) 324 (Assert= (/ three 2.0) 1.5 three))
325 (dolist (two '(2 2.0 ?\02)) 325 (dolist (two '(2 2.0 ?\02))
326 (Assert (= (/ 3.0 two) 1.5) two)) 326 (Assert= (/ 3.0 two) 1.5 two))
327 327
328 (when (featurep 'bignum) 328 (when (featurep 'bignum)
329 (let* ((million 1000000) 329 (let* ((million 1000000)
330 (billion (* million 1000)) ;; American, not British, billion 330 (billion (* million 1000)) ;; American, not British, billion
331 (trillion (* billion 1000))) 331 (trillion (* billion 1000)))
332 (Assert (= (/ billion 1000) (/ trillion million) million 1000000.0)) 332 (Assert= (/ billion 1000) (/ trillion million) million 1000000.0)
333 (Assert (= (/ billion -1000) (/ trillion (- million)) (- million))) 333 (Assert= (/ billion -1000) (/ trillion (- million)) (- million))
334 (Assert (= (/ trillion 1000) billion 1000000000.0)) 334 (Assert= (/ trillion 1000) billion 1000000000.0)
335 (Assert (= (/ trillion -1000) (- billion) -1000000000.0)) 335 (Assert= (/ trillion -1000) (- billion) -1000000000.0)
336 (Assert (= (/ trillion 10) (* 100 billion) 100000000000.0)) 336 (Assert= (/ trillion 10) (* 100 billion) 100000000000.0)
337 (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0)))) 337 (Assert= (/ (- trillion) 10) (* -100 billion) -100000000000.0)))
338 338
339 (when (featurep 'ratio) 339 (when (featurep 'ratio)
340 (let ((half (div 1 2)) 340 (let ((half (div 1 2))
341 (fivefourths (div 5 4)) 341 (fivefourths (div 5 4))
342 (fivehalfs (div 5 2))) 342 (fivehalfs (div 5 2)))
343 (Assert (= half (read "3000000000/6000000000"))) 343 (Assert= half (read "3000000000/6000000000"))
344 (Assert (= (/ fivehalfs fivefourths) 2)) 344 (Assert= (/ fivehalfs fivefourths) 2)
345 (Assert (= (/ fivefourths fivehalfs) half)) 345 (Assert= (/ fivefourths fivehalfs) half)
346 (Assert (= (- half) (read "-3000000000/6000000000"))) 346 (Assert= (- half) (read "-3000000000/6000000000"))
347 (Assert (= (/ fivehalfs (- fivefourths)) -2)) 347 (Assert= (/ fivehalfs (- fivefourths)) -2)
348 (Assert (= (/ (- fivefourths) fivehalfs) (- half))))) 348 (Assert= (/ (- fivefourths) fivehalfs) (- half))))
349 349
350 ;; Test `*' 350 ;; Test `*'
351 (Assert (= 1 (*))) 351 (Assert= 1 (*))
352 352
353 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) 353 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
354 (Assert (= 1 (* one)) one)) 354 (Assert= 1 (* one) one))
355 355
356 (dolist (two '(2 2.0 ?\02)) 356 (dolist (two '(2 2.0 ?\02))
357 (Assert (= 2 (* two)) two)) 357 (Assert= 2 (* two) two))
358 358
359 (dolist (six '(6 6.0 ?\06)) 359 (dolist (six '(6 6.0 ?\06))
360 (dolist (two '(2 2.0 ?\02)) 360 (dolist (two '(2 2.0 ?\02))
361 (dolist (three '(3 3.0 ?\03)) 361 (dolist (three '(3 3.0 ?\03))
362 (Assert (= (* three two) six) (list three two six))))) 362 (Assert= (* three two) six (list three two six)))))
363 363
364 (dolist (three '(3 3.0 ?\03)) 364 (dolist (three '(3 3.0 ?\03))
365 (dolist (two '(2 2.0 ?\02)) 365 (dolist (two '(2 2.0 ?\02))
366 (Assert (= (* 1.5 two) three) (list two three)) 366 (Assert= (* 1.5 two) three (list two three))
367 (dolist (five '(5 5.0 ?\05)) 367 (dolist (five '(5 5.0 ?\05))
368 (Assert (= 30 (* five two three)) (list five two three))))) 368 (Assert= 30 (* five two three) (list five two three)))))
369 369
370 (when (featurep 'bignum) 370 (when (featurep 'bignum)
371 (let ((64K 65536)) 371 (let ((64K 65536))
372 (Assert (= (* 64K 64K) (read "4294967296"))) 372 (Assert= (* 64K 64K) (read "4294967296"))
373 (Assert (= (* (- 64K) 64K) (read "-4294967296"))) 373 (Assert= (* (- 64K) 64K) (read "-4294967296"))
374 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum)))) 374 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum))))
375 375
376 (when (featurep 'ratio) 376 (when (featurep 'ratio)
377 (let ((half (div 1 2)) 377 (let ((half (div 1 2))
378 (fivefourths (div 5 4)) 378 (fivefourths (div 5 4))
379 (twofifths (div 2 5))) 379 (twofifths (div 2 5)))
380 (Assert (= (* fivefourths twofifths) half)) 380 (Assert= (* fivefourths twofifths) half)
381 (Assert (= (* half twofifths) (read "3/15"))))) 381 (Assert= (* half twofifths) (read "3/15"))))
382 382
383 ;; Test `+' 383 ;; Test `+'
384 (Assert (= 0 (+))) 384 (Assert= 0 (+))
385 385
386 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) 386 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
387 (Assert (= 1 (+ one)) one)) 387 (Assert= 1 (+ one) one))
388 388
389 (dolist (two '(2 2.0 ?\02)) 389 (dolist (two '(2 2.0 ?\02))
390 (Assert (= 2 (+ two)) two)) 390 (Assert= 2 (+ two) two))
391 391
392 (dolist (five '(5 5.0 ?\05)) 392 (dolist (five '(5 5.0 ?\05))
393 (dolist (two '(2 2.0 ?\02)) 393 (dolist (two '(2 2.0 ?\02))
394 (dolist (three '(3 3.0 ?\03)) 394 (dolist (three '(3 3.0 ?\03))
395 (Assert (= (+ three two) five) (list three two five)) 395 (Assert= (+ three two) five (list three two five))
396 (Assert (= 10 (+ five two three)) (list five two three))))) 396 (Assert= 10 (+ five two three) (list five two three)))))
397 397
398 ;; Test `max', `min' 398 ;; Test `max', `min'
399 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) 399 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
400 (Assert (= one (max one)) one) 400 (Assert= one (max one) one)
401 (Assert (= one (max one one)) one) 401 (Assert= one (max one one) one)
402 (Assert (= one (max one one one)) one) 402 (Assert= one (max one one one) one)
403 (Assert (= one (min one)) one) 403 (Assert= one (min one) one)
404 (Assert (= one (min one one)) one) 404 (Assert= one (min one one) one)
405 (Assert (= one (min one one one)) one) 405 (Assert= one (min one one one) one)
406 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) 406 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2)))
407 (Assert (= one (min one two)) (list one two)) 407 (Assert= one (min one two) (list one two))
408 (Assert (= one (min one two two)) (list one two)) 408 (Assert= one (min one two two) (list one two))
409 (Assert (= one (min two two one)) (list one two)) 409 (Assert= one (min two two one) (list one two))
410 (Assert (= two (max one two)) (list one two)) 410 (Assert= two (max one two) (list one two))
411 (Assert (= two (max one two two)) (list one two)) 411 (Assert= two (max one two two) (list one two))
412 (Assert (= two (max two two one)) (list one two)))) 412 (Assert= two (max two two one) (list one two))))
413 413
414 (when (featurep 'bignum) 414 (when (featurep 'bignum)
415 (let ((big (1+ most-positive-fixnum)) 415 (let ((big (1+ most-positive-fixnum))
416 (small (1- most-negative-fixnum))) 416 (small (1- most-negative-fixnum)))
417 (Assert (= big (max 1 1000000.0 most-positive-fixnum big))) 417 (Assert= big (max 1 1000000.0 most-positive-fixnum big))
418 (Assert (= small (min -1 -1000000.0 most-negative-fixnum small))))) 418 (Assert= small (min -1 -1000000.0 most-negative-fixnum small))))
419 419
420 (when (featurep 'ratio) 420 (when (featurep 'ratio)
421 (let* ((big (1+ most-positive-fixnum)) 421 (let* ((big (1+ most-positive-fixnum))
422 (small (1- most-negative-fixnum)) 422 (small (1- most-negative-fixnum))
423 (bigr (div (* 5 (1+ most-positive-fixnum)) 4)) 423 (bigr (div (* 5 (1+ most-positive-fixnum)) 4))
424 (smallr (- bigr))) 424 (smallr (- bigr)))
425 (Assert (= bigr (max 1 1000000.0 most-positive-fixnum big bigr))) 425 (Assert= bigr (max 1 1000000.0 most-positive-fixnum big bigr))
426 (Assert (= smallr (min -1 -1000000.0 most-negative-fixnum small smallr))))) 426 (Assert= smallr (min -1 -1000000.0 most-negative-fixnum small smallr))))
427 427
428 ;; The byte compiler has special handling for these constructs: 428 ;; The byte compiler has special handling for these constructs:
429 (let ((three 3) (five 5)) 429 (let ((three 3) (five 5))
430 (Assert (= (+ three five 1) 9)) 430 (Assert= (+ three five 1) 9)
431 (Assert (= (+ 1 three five) 9)) 431 (Assert= (+ 1 three five) 9)
432 (Assert (= (+ three five -1) 7)) 432 (Assert= (+ three five -1) 7)
433 (Assert (= (+ -1 three five) 7)) 433 (Assert= (+ -1 three five) 7)
434 (Assert (= (+ three 1) 4)) 434 (Assert= (+ three 1) 4)
435 (Assert (= (+ three -1) 2)) 435 (Assert= (+ three -1) 2)
436 (Assert (= (+ -1 three) 2)) 436 (Assert= (+ -1 three) 2)
437 (Assert (= (+ -1 three) 2)) 437 (Assert= (+ -1 three) 2)
438 (Assert (= (- three five 1) -3)) 438 (Assert= (- three five 1) -3)
439 (Assert (= (- 1 three five) -7)) 439 (Assert= (- 1 three five) -7)
440 (Assert (= (- three five -1) -1)) 440 (Assert= (- three five -1) -1)
441 (Assert (= (- -1 three five) -9)) 441 (Assert= (- -1 three five) -9)
442 (Assert (= (- three 1) 2)) 442 (Assert= (- three 1) 2)
443 (Assert (= (- three 2 1) 0)) 443 (Assert= (- three 2 1) 0)
444 (Assert (= (- 2 three 1) -2)) 444 (Assert= (- 2 three 1) -2)
445 (Assert (= (- three -1) 4)) 445 (Assert= (- three -1) 4)
446 (Assert (= (- three 0) 3)) 446 (Assert= (- three 0) 3)
447 (Assert (= (- three 0 five) -2)) 447 (Assert= (- three 0 five) -2)
448 (Assert (= (- 0 three 0 five) -8)) 448 (Assert= (- 0 three 0 five) -8)
449 (Assert (= (- 0 three five) -8)) 449 (Assert= (- 0 three five) -8)
450 (Assert (= (* three 2) 6)) 450 (Assert= (* three 2) 6)
451 (Assert (= (* three -1 five) -15)) 451 (Assert= (* three -1 five) -15)
452 (Assert (= (* three 1 five) 15)) 452 (Assert= (* three 1 five) 15)
453 (Assert (= (* three 0 five) 0)) 453 (Assert= (* three 0 five) 0)
454 (Assert (= (* three 2 five) 30)) 454 (Assert= (* three 2 five) 30)
455 (Assert (= (/ three 1) 3)) 455 (Assert= (/ three 1) 3)
456 (Assert (= (/ three -1) -3)) 456 (Assert= (/ three -1) -3)
457 (Assert (= (/ (* five five) 2 2) 6)) 457 (Assert= (/ (* five five) 2 2) 6)
458 (Assert (= (/ 64 five 2) 6))) 458 (Assert= (/ 64 five 2) 6))
459 459
460 460
461 ;;----------------------------------------------------- 461 ;;-----------------------------------------------------
462 ;; Logical bit-twiddling operations 462 ;; Logical bit-twiddling operations
463 ;;----------------------------------------------------- 463 ;;-----------------------------------------------------
464 (Assert (= (logxor) 0)) 464 (Assert= (logxor) 0)
465 (Assert (= (logior) 0)) 465 (Assert= (logior) 0)
466 (Assert (= (logand) -1)) 466 (Assert= (logand) -1)
467 467
468 (Check-Error wrong-type-argument (logxor 3.0)) 468 (Check-Error wrong-type-argument (logxor 3.0))
469 (Check-Error wrong-type-argument (logior 3.0)) 469 (Check-Error wrong-type-argument (logior 3.0))
470 (Check-Error wrong-type-argument (logand 3.0)) 470 (Check-Error wrong-type-argument (logand 3.0))
471 471
472 (dolist (three '(3 ?\03)) 472 (dolist (three '(3 ?\03))
473 (Assert (eq 3 (logand three)) three) 473 (Assert-eq 3 (logand three) three)
474 (Assert (eq 3 (logxor three)) three) 474 (Assert-eq 3 (logxor three) three)
475 (Assert (eq 3 (logior three)) three) 475 (Assert-eq 3 (logior three) three)
476 (Assert (eq 3 (logand three three)) three) 476 (Assert-eq 3 (logand three three) three)
477 (Assert (eq 0 (logxor three three)) three) 477 (Assert-eq 0 (logxor three three) three)
478 (Assert (eq 3 (logior three three))) three) 478 (Assert-eq 3 (logior three three)) three)
479 479
480 (dolist (one `(1 ?\01 ,(Int-to-Marker 1))) 480 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
481 (dolist (two '(2 ?\02)) 481 (dolist (two '(2 ?\02))
482 (Assert (eq 0 (logand one two)) (list one two)) 482 (Assert-eq 0 (logand one two) (list one two))
483 (Assert (eq 3 (logior one two)) (list one two)) 483 (Assert-eq 3 (logior one two) (list one two))
484 (Assert (eq 3 (logxor one two)) (list one two))) 484 (Assert-eq 3 (logxor one two) (list one two)))
485 (dolist (three '(3 ?\03)) 485 (dolist (three '(3 ?\03))
486 (Assert (eq 1 (logand one three)) (list one three)) 486 (Assert-eq 1 (logand one three) (list one three))
487 (Assert (eq 3 (logior one three)) (list one three)) 487 (Assert-eq 3 (logior one three) (list one three))
488 (Assert (eq 2 (logxor one three)) (list one three)))) 488 (Assert-eq 2 (logxor one three) (list one three))))
489 489
490 ;;----------------------------------------------------- 490 ;;-----------------------------------------------------
491 ;; Test `%', mod 491 ;; Test `%', mod
492 ;;----------------------------------------------------- 492 ;;-----------------------------------------------------
493 (Check-Error wrong-number-of-arguments (%)) 493 (Check-Error wrong-number-of-arguments (%))
499 (Check-Error wrong-number-of-arguments (mod 1 2 3)) 499 (Check-Error wrong-number-of-arguments (mod 1 2 3))
500 500
501 (Check-Error wrong-type-argument (% 10.0 2)) 501 (Check-Error wrong-type-argument (% 10.0 2))
502 (Check-Error wrong-type-argument (% 10 2.0)) 502 (Check-Error wrong-type-argument (% 10 2.0))
503 503
504 (flet ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x)) 504 (flet ((test1 (x) (Assert-eql x (+ (% x 17) (* (/ x 17) 17)) x))
505 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) 505 (test2 (x) (Assert-eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17)) x))
506 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) 506 (test3 (x) (Assert-eql x (+ (% (- x) 17) (* (/ (- x) 17) 17)) x))
507 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x)) 507 (test4 (x) (Assert-eql (% x -17) (- (% (- x) 17)) x))
508 (test5 (x) (Assert (eql (% x -17) (% (- x) 17))) x)) 508 (test5 (x) (Assert-eql (% x -17) (% (- x) 17)) x))
509 (test1 most-negative-fixnum) 509 (test1 most-negative-fixnum)
510 (if (featurep 'bignum) 510 (if (featurep 'bignum)
511 (progn 511 (progn
512 (test2 most-negative-fixnum) 512 (test2 most-negative-fixnum)
513 (test4 most-negative-fixnum)) 513 (test4 most-negative-fixnum))
525 (test4 x)))) 525 (test4 x))))
526 526
527 (macrolet 527 (macrolet
528 ((division-test (seven) 528 ((division-test (seven)
529 `(progn 529 `(progn
530 (Assert (eq (% ,seven 2) 1)) 530 (Assert-eq (% ,seven 2) 1)
531 (Assert (eq (% ,seven -2) 1)) 531 (Assert-eq (% ,seven -2) 1)
532 (Assert (eq (% (- ,seven) 2) -1)) 532 (Assert-eq (% (- ,seven) 2) -1)
533 (Assert (eq (% (- ,seven) -2) -1)) 533 (Assert-eq (% (- ,seven) -2) -1)
534 534
535 (Assert (eq (% ,seven 4) 3)) 535 (Assert-eq (% ,seven 4) 3)
536 (Assert (eq (% ,seven -4) 3)) 536 (Assert-eq (% ,seven -4) 3)
537 (Assert (eq (% (- ,seven) 4) -3)) 537 (Assert-eq (% (- ,seven) 4) -3)
538 (Assert (eq (% (- ,seven) -4) -3)) 538 (Assert-eq (% (- ,seven) -4) -3)
539 539
540 (Assert (eq (% 35 ,seven) 0)) 540 (Assert-eq (% 35 ,seven) 0)
541 (Assert (eq (% -35 ,seven) 0)) 541 (Assert-eq (% -35 ,seven) 0)
542 (Assert (eq (% 35 (- ,seven)) 0)) 542 (Assert-eq (% 35 (- ,seven)) 0)
543 (Assert (eq (% -35 (- ,seven)) 0)) 543 (Assert-eq (% -35 (- ,seven)) 0)
544 544
545 (Assert (eq (mod ,seven 2) 1)) 545 (Assert-eq (mod ,seven 2) 1)
546 (Assert (eq (mod ,seven -2) -1)) 546 (Assert-eq (mod ,seven -2) -1)
547 (Assert (eq (mod (- ,seven) 2) 1)) 547 (Assert-eq (mod (- ,seven) 2) 1)
548 (Assert (eq (mod (- ,seven) -2) -1)) 548 (Assert-eq (mod (- ,seven) -2) -1)
549 549
550 (Assert (eq (mod ,seven 4) 3)) 550 (Assert-eq (mod ,seven 4) 3)
551 (Assert (eq (mod ,seven -4) -1)) 551 (Assert-eq (mod ,seven -4) -1)
552 (Assert (eq (mod (- ,seven) 4) 1)) 552 (Assert-eq (mod (- ,seven) 4) 1)
553 (Assert (eq (mod (- ,seven) -4) -3)) 553 (Assert-eq (mod (- ,seven) -4) -3)
554 554
555 (Assert (eq (mod 35 ,seven) 0)) 555 (Assert-eq (mod 35 ,seven) 0)
556 (Assert (eq (mod -35 ,seven) 0)) 556 (Assert-eq (mod -35 ,seven) 0)
557 (Assert (eq (mod 35 (- ,seven)) 0)) 557 (Assert-eq (mod 35 (- ,seven)) 0)
558 (Assert (eq (mod -35 (- ,seven)) 0)) 558 (Assert-eq (mod -35 (- ,seven)) 0)
559 559
560 (Assert (= (mod ,seven 2.0) 1.0)) 560 (Assert= (mod ,seven 2.0) 1.0)
561 (Assert (= (mod ,seven -2.0) -1.0)) 561 (Assert= (mod ,seven -2.0) -1.0)
562 (Assert (= (mod (- ,seven) 2.0) 1.0)) 562 (Assert= (mod (- ,seven) 2.0) 1.0)
563 (Assert (= (mod (- ,seven) -2.0) -1.0)) 563 (Assert= (mod (- ,seven) -2.0) -1.0)
564 564
565 (Assert (= (mod ,seven 4.0) 3.0)) 565 (Assert= (mod ,seven 4.0) 3.0)
566 (Assert (= (mod ,seven -4.0) -1.0)) 566 (Assert= (mod ,seven -4.0) -1.0)
567 (Assert (= (mod (- ,seven) 4.0) 1.0)) 567 (Assert= (mod (- ,seven) 4.0) 1.0)
568 (Assert (= (mod (- ,seven) -4.0) -3.0)) 568 (Assert= (mod (- ,seven) -4.0) -3.0)
569 569
570 (Assert (eq (% 0 ,seven) 0)) 570 (Assert-eq (% 0 ,seven) 0)
571 (Assert (eq (% 0 (- ,seven)) 0)) 571 (Assert-eq (% 0 (- ,seven)) 0)
572 572
573 (Assert (eq (mod 0 ,seven) 0)) 573 (Assert-eq (mod 0 ,seven) 0)
574 (Assert (eq (mod 0 (- ,seven)) 0)) 574 (Assert-eq (mod 0 (- ,seven)) 0)
575 575
576 (Assert (= (mod 0.0 ,seven) 0.0)) 576 (Assert= (mod 0.0 ,seven) 0.0)
577 (Assert (= (mod 0.0 (- ,seven)) 0.0))))) 577 (Assert= (mod 0.0 (- ,seven)) 0.0))))
578 578
579 (division-test 7) 579 (division-test 7)
580 (division-test ?\07) 580 (division-test ?\07)
581 (division-test (Int-to-Marker 7))) 581 (division-test (Int-to-Marker 7)))
582 582
598 (Check-Error wrong-number-of-arguments (>=)) 598 (Check-Error wrong-number-of-arguments (>=))
599 (Check-Error wrong-number-of-arguments (/=)) 599 (Check-Error wrong-number-of-arguments (/=))
600 600
601 ;; One argument always yields t 601 ;; One argument always yields t
602 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do 602 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do
603 (Assert (eq t (= x)) x) 603 (Assert-eq t (= x) x)
604 (Assert (eq t (< x)) x) 604 (Assert-eq t (< x) x)
605 (Assert (eq t (> x)) x) 605 (Assert-eq t (> x) x)
606 (Assert (eq t (>= x)) x) 606 (Assert-eq t (>= x) x)
607 (Assert (eq t (<= x)) x) 607 (Assert-eq t (<= x) x)
608 (Assert (eq t (/= x)) x) 608 (Assert-eq t (/= x) x)
609 ) 609 )
610 610
611 ;; Type checking 611 ;; Type checking
612 (Check-Error wrong-type-argument (= 'foo 1)) 612 (Check-Error wrong-type-argument (= 'foo 1))
613 (Check-Error wrong-type-argument (<= 'foo 1)) 613 (Check-Error wrong-type-argument (<= 'foo 1))
631 (Assert (not (> one one)) one) 631 (Assert (not (> one one)) one)
632 (Assert (<= one one two two) (list one two)) 632 (Assert (<= one one two two) (list one two))
633 (Assert (not (< one one two two)) (list one two)) 633 (Assert (not (< one one two two)) (list one two))
634 (Assert (>= two two one one) (list one two)) 634 (Assert (>= two two one one) (list one two))
635 (Assert (not (> two two one one)) (list one two)) 635 (Assert (not (> two two one one)) (list one two))
636 (Assert (= one one one) one) 636 (Assert= one one one one)
637 (Assert (not (= one one one two)) (list one two)) 637 (Assert (not (= one one one two)) (list one two))
638 (Assert (not (/= one two one)) (list one two)) 638 (Assert (not (/= one two one)) (list one two))
639 )) 639 ))
640 640
641 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) 641 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
652 (Assert (not (> one one)) one) 652 (Assert (not (> one one)) one)
653 (Assert (<= one one two two) (list one two)) 653 (Assert (<= one one two two) (list one two))
654 (Assert (not (< one one two two)) (list one two)) 654 (Assert (not (< one one two two)) (list one two))
655 (Assert (>= two two one one) (list one two)) 655 (Assert (>= two two one one) (list one two))
656 (Assert (not (> two two one one)) (list one two)) 656 (Assert (not (> two two one one)) (list one two))
657 (Assert (= one one one) one) 657 (Assert= one one one one)
658 (Assert (not (= one one one two)) (list one two)) 658 (Assert (not (= one one one two)) (list one two))
659 (Assert (not (/= one two one)) (list one two)) 659 (Assert (not (/= one two one)) (list one two))
660 )) 660 ))
661 661
662 ;; ad-hoc 662 ;; ad-hoc
672 (Assert (<= 1 2 3 4 5 6 6)) 672 (Assert (<= 1 2 3 4 5 6 6))
673 (Assert (not (< 1 2 3 4 5 6 6))) 673 (Assert (not (< 1 2 3 4 5 6 6)))
674 (Assert (<= 1 1)) 674 (Assert (<= 1 1))
675 675
676 (Assert (not (eq (point) (point-marker)))) 676 (Assert (not (eq (point) (point-marker))))
677 (Assert (= 1 (Int-to-Marker 1))) 677 (Assert= 1 (Int-to-Marker 1))
678 (Assert (= (point) (point-marker))) 678 (Assert= (point) (point-marker))
679 679
680 (when (featurep 'bignum) 680 (when (featurep 'bignum)
681 (let ((big1 (1+ most-positive-fixnum)) 681 (let ((big1 (1+ most-positive-fixnum))
682 (big2 (* 10 most-positive-fixnum)) 682 (big2 (* 10 most-positive-fixnum))
683 (small1 (1- most-negative-fixnum)) 683 (small1 (1- most-negative-fixnum))
698 (big2 (div (* 5 most-positive-fixnum) 2)) 698 (big2 (div (* 5 most-positive-fixnum) 2))
699 (big3 (div (* 7 most-positive-fixnum) 2)) 699 (big3 (div (* 7 most-positive-fixnum) 2))
700 (small1 (div (* 10 most-negative-fixnum) 4)) 700 (small1 (div (* 10 most-negative-fixnum) 4))
701 (small2 (div (* 5 most-negative-fixnum) 2)) 701 (small2 (div (* 5 most-negative-fixnum) 2))
702 (small3 (div (* 7 most-negative-fixnum) 2))) 702 (small3 (div (* 7 most-negative-fixnum) 2)))
703 (Assert (= big1 big2)) 703 (Assert= big1 big2)
704 (Assert (= small1 small2)) 704 (Assert= small1 small2)
705 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1 705 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1
706 big3)) 706 big3))
707 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum 707 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum
708 big1 big2 big3)) 708 big1 big2 big3))
709 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1 709 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1
735 delete old-delete 735 delete old-delete
736 delq old-delq 736 delq old-delq
737 remassoc remassq remrassoc remrassq)) 737 remassoc remassq remrassoc remrassq))
738 738
739 (let ((x '((1 . 2) 3 (4 . 5)))) 739 (let ((x '((1 . 2) 3 (4 . 5))))
740 (Assert (eq (assoc 1 x) (car x))) 740 (Assert-eq (assoc 1 x) (car x))
741 (Assert (eq (assq 1 x) (car x))) 741 (Assert-eq (assq 1 x) (car x))
742 (Assert (eq (rassoc 1 x) nil)) 742 (Assert-eq (rassoc 1 x) nil)
743 (Assert (eq (rassq 1 x) nil)) 743 (Assert-eq (rassq 1 x) nil)
744 (Assert (eq (assoc 2 x) nil)) 744 (Assert-eq (assoc 2 x) nil)
745 (Assert (eq (assq 2 x) nil)) 745 (Assert-eq (assq 2 x) nil)
746 (Assert (eq (rassoc 2 x) (car x))) 746 (Assert-eq (rassoc 2 x) (car x))
747 (Assert (eq (rassq 2 x) (car x))) 747 (Assert-eq (rassq 2 x) (car x))
748 (Assert (eq (assoc 3 x) nil)) 748 (Assert-eq (assoc 3 x) nil)
749 (Assert (eq (assq 3 x) nil)) 749 (Assert-eq (assq 3 x) nil)
750 (Assert (eq (rassoc 3 x) nil)) 750 (Assert-eq (rassoc 3 x) nil)
751 (Assert (eq (rassq 3 x) nil)) 751 (Assert-eq (rassq 3 x) nil)
752 (Assert (eq (assoc 4 x) (caddr x))) 752 (Assert-eq (assoc 4 x) (caddr x))
753 (Assert (eq (assq 4 x) (caddr x))) 753 (Assert-eq (assq 4 x) (caddr x))
754 (Assert (eq (rassoc 4 x) nil)) 754 (Assert-eq (rassoc 4 x) nil)
755 (Assert (eq (rassq 4 x) nil)) 755 (Assert-eq (rassq 4 x) nil)
756 (Assert (eq (assoc 5 x) nil)) 756 (Assert-eq (assoc 5 x) nil)
757 (Assert (eq (assq 5 x) nil)) 757 (Assert-eq (assq 5 x) nil)
758 (Assert (eq (rassoc 5 x) (caddr x))) 758 (Assert-eq (rassoc 5 x) (caddr x))
759 (Assert (eq (rassq 5 x) (caddr x))) 759 (Assert-eq (rassq 5 x) (caddr x))
760 (Assert (eq (assoc 6 x) nil)) 760 (Assert-eq (assoc 6 x) nil)
761 (Assert (eq (assq 6 x) nil)) 761 (Assert-eq (assq 6 x) nil)
762 (Assert (eq (rassoc 6 x) nil)) 762 (Assert-eq (rassoc 6 x) nil)
763 (Assert (eq (rassq 6 x) nil))) 763 (Assert-eq (rassq 6 x) nil))
764 764
765 (let ((x '(("1" . "2") "3" ("4" . "5")))) 765 (let ((x '(("1" . "2") "3" ("4" . "5"))))
766 (Assert (eq (assoc "1" x) (car x))) 766 (Assert-eq (assoc "1" x) (car x))
767 (Assert (eq (assq "1" x) nil)) 767 (Assert-eq (assq "1" x) nil)
768 (Assert (eq (rassoc "1" x) nil)) 768 (Assert-eq (rassoc "1" x) nil)
769 (Assert (eq (rassq "1" x) nil)) 769 (Assert-eq (rassq "1" x) nil)
770 (Assert (eq (assoc "2" x) nil)) 770 (Assert-eq (assoc "2" x) nil)
771 (Assert (eq (assq "2" x) nil)) 771 (Assert-eq (assq "2" x) nil)
772 (Assert (eq (rassoc "2" x) (car x))) 772 (Assert-eq (rassoc "2" x) (car x))
773 (Assert (eq (rassq "2" x) nil)) 773 (Assert-eq (rassq "2" x) nil)
774 (Assert (eq (assoc "3" x) nil)) 774 (Assert-eq (assoc "3" x) nil)
775 (Assert (eq (assq "3" x) nil)) 775 (Assert-eq (assq "3" x) nil)
776 (Assert (eq (rassoc "3" x) nil)) 776 (Assert-eq (rassoc "3" x) nil)
777 (Assert (eq (rassq "3" x) nil)) 777 (Assert-eq (rassq "3" x) nil)
778 (Assert (eq (assoc "4" x) (caddr x))) 778 (Assert-eq (assoc "4" x) (caddr x))
779 (Assert (eq (assq "4" x) nil)) 779 (Assert-eq (assq "4" x) nil)
780 (Assert (eq (rassoc "4" x) nil)) 780 (Assert-eq (rassoc "4" x) nil)
781 (Assert (eq (rassq "4" x) nil)) 781 (Assert-eq (rassq "4" x) nil)
782 (Assert (eq (assoc "5" x) nil)) 782 (Assert-eq (assoc "5" x) nil)
783 (Assert (eq (assq "5" x) nil)) 783 (Assert-eq (assq "5" x) nil)
784 (Assert (eq (rassoc "5" x) (caddr x))) 784 (Assert-eq (rassoc "5" x) (caddr x))
785 (Assert (eq (rassq "5" x) nil)) 785 (Assert-eq (rassq "5" x) nil)
786 (Assert (eq (assoc "6" x) nil)) 786 (Assert-eq (assoc "6" x) nil)
787 (Assert (eq (assq "6" x) nil)) 787 (Assert-eq (assq "6" x) nil)
788 (Assert (eq (rassoc "6" x) nil)) 788 (Assert-eq (rassoc "6" x) nil)
789 (Assert (eq (rassq "6" x) nil))) 789 (Assert-eq (rassq "6" x) nil))
790 790
791 (flet ((a () (list '(1 . 2) 3 '(4 . 5)))) 791 (flet ((a () (list '(1 . 2) 3 '(4 . 5))))
792 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) 792 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
793 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) 793 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
794 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a))))) 794 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a)))))
866 ;;----------------------------------------------------- 866 ;;-----------------------------------------------------
867 ;; function-max-args, function-min-args 867 ;; function-max-args, function-min-args
868 ;;----------------------------------------------------- 868 ;;-----------------------------------------------------
869 (defmacro check-function-argcounts (fun min max) 869 (defmacro check-function-argcounts (fun min max)
870 `(progn 870 `(progn
871 (Assert (eq (function-min-args ,fun) ,min)) 871 (Assert-eq (function-min-args ,fun) ,min)
872 (Assert (eq (function-max-args ,fun) ,max)))) 872 (Assert-eq (function-max-args ,fun) ,max)))
873 873
874 (check-function-argcounts 'prog1 1 nil) ; special form 874 (check-function-argcounts 'prog1 1 nil) ; special form
875 (check-function-argcounts 'command-execute 1 3) ; normal subr 875 (check-function-argcounts 'command-execute 1 3) ; normal subr
876 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr 876 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr
877 (check-function-argcounts 'garbage-collect 0 0) ; no args subr 877 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
894 '((let (1 . unevalled)) 894 '((let (1 . unevalled))
895 (prog1 (1 . unevalled)) 895 (prog1 (1 . unevalled))
896 (list (0 . many)) 896 (list (0 . many))
897 (type-of (1 . 1)) 897 (type-of (1 . 1))
898 (garbage-collect (0 . 0))) 898 (garbage-collect (0 . 0)))
899 do (Assert (equal (subr-arity (symbol-function function-name)) arity))) 899 do (Assert-equal (subr-arity (symbol-function function-name)) arity))
900 900
901 (Check-Error wrong-type-argument (subr-arity 901 (Check-Error wrong-type-argument (subr-arity
902 (lambda () (message "Hi there!")))) 902 (lambda () (message "Hi there!"))))
903 903
904 (Check-Error wrong-type-argument (subr-arity nil)) 904 (Check-Error wrong-type-argument (subr-arity nil))
916 (fmakunbound 'test-sym2) 916 (fmakunbound 'test-sym2)
917 917
918 ;;----------------------------------------------------- 918 ;;-----------------------------------------------------
919 ;; Test `type-of' 919 ;; Test `type-of'
920 ;;----------------------------------------------------- 920 ;;-----------------------------------------------------
921 (Assert (eq (type-of load-path) 'cons)) 921 (Assert-eq (type-of load-path) 'cons)
922 (Assert (eq (type-of obarray) 'vector)) 922 (Assert-eq (type-of obarray) 'vector)
923 (Assert (eq (type-of 42) 'integer)) 923 (Assert-eq (type-of 42) 'integer)
924 (Assert (eq (type-of ?z) 'character)) 924 (Assert-eq (type-of ?z) 'character)
925 (Assert (eq (type-of "42") 'string)) 925 (Assert-eq (type-of "42") 'string)
926 (Assert (eq (type-of 'foo) 'symbol)) 926 (Assert-eq (type-of 'foo) 'symbol)
927 (Assert (eq (type-of (selected-device)) 'device)) 927 (Assert-eq (type-of (selected-device)) 'device)
928 928
929 ;;----------------------------------------------------- 929 ;;-----------------------------------------------------
930 ;; Test mapping functions 930 ;; Test mapping functions
931 ;;----------------------------------------------------- 931 ;;-----------------------------------------------------
932 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer))) 932 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer)))
933 (Assert (equal (mapcar #'identity load-path) load-path)) 933 (Assert-equal (mapcar #'identity load-path) load-path)
934 (Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3))) 934 (Assert-equal (mapcar #'identity '(1 2 3)) '(1 2 3))
935 (Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3))) 935 (Assert-equal (mapcar #'identity "123") '(?1 ?2 ?3))
936 (Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3))) 936 (Assert-equal (mapcar #'identity [1 2 3]) '(1 2 3))
937 (Assert (equal (mapcar #'identity #*010) '(0 1 0))) 937 (Assert-equal (mapcar #'identity #*010) '(0 1 0))
938 938
939 (let ((z 0) (list (make-list 1000 1))) 939 (let ((z 0) (list (make-list 1000 1)))
940 (mapc (lambda (x) (incf z x)) list) 940 (mapc (lambda (x) (incf z x)) list)
941 (Assert (eq 1000 z))) 941 (Assert-eq 1000 z))
942 942
943 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer))) 943 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer)))
944 (Assert (equal (mapvector #'identity '(1 2 3)) [1 2 3])) 944 (Assert-equal (mapvector #'identity '(1 2 3)) [1 2 3])
945 (Assert (equal (mapvector #'identity "123") [?1 ?2 ?3])) 945 (Assert-equal (mapvector #'identity "123") [?1 ?2 ?3])
946 (Assert (equal (mapvector #'identity [1 2 3]) [1 2 3])) 946 (Assert-equal (mapvector #'identity [1 2 3]) [1 2 3])
947 (Assert (equal (mapvector #'identity #*010) [0 1 0])) 947 (Assert-equal (mapvector #'identity #*010) [0 1 0])
948 948
949 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo")) 949 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo"))
950 (Assert (equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3")) 950 (Assert-equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3")
951 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3")) 951 (Assert-equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3")
952 952
953 ;; The following 2 functions used to crash XEmacs via mapcar1(). 953 ;; The following 2 functions used to crash XEmacs via mapcar1().
954 ;; We don't test the actual values of the mapcar, since they're undefined. 954 ;; We don't test the actual values of the mapcar, since they're undefined.
955 (Assert 955 (Assert
956 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) 956 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
974 x))) 974 x)))
975 975
976 ;;----------------------------------------------------- 976 ;;-----------------------------------------------------
977 ;; Test vector functions 977 ;; Test vector functions
978 ;;----------------------------------------------------- 978 ;;-----------------------------------------------------
979 (Assert (equal [1 2 3] [1 2 3])) 979 (Assert-equal [1 2 3] [1 2 3])
980 (Assert (equal [] [])) 980 (Assert-equal [] [])
981 (Assert (not (equal [1 2 3] []))) 981 (Assert (not (equal [1 2 3] [])))
982 (Assert (not (equal [1 2 3] [1 2 4]))) 982 (Assert (not (equal [1 2 3] [1 2 4])))
983 (Assert (not (equal [0 2 3] [1 2 3]))) 983 (Assert (not (equal [0 2 3] [1 2 3])))
984 (Assert (not (equal [1 2 3] [1 2 3 4]))) 984 (Assert (not (equal [1 2 3] [1 2 3 4])))
985 (Assert (not (equal [1 2 3 4] [1 2 3]))) 985 (Assert (not (equal [1 2 3 4] [1 2 3])))
986 (Assert (equal (vector 1 2 3) [1 2 3])) 986 (Assert-equal (vector 1 2 3) [1 2 3])
987 (Assert (equal (make-vector 3 1) [1 1 1])) 987 (Assert-equal (make-vector 3 1) [1 1 1])
988 988
989 ;;----------------------------------------------------- 989 ;;-----------------------------------------------------
990 ;; Test bit-vector functions 990 ;; Test bit-vector functions
991 ;;----------------------------------------------------- 991 ;;-----------------------------------------------------
992 (Assert (equal #*010 #*010)) 992 (Assert-equal #*010 #*010)
993 (Assert (equal #* #*)) 993 (Assert-equal #* #*)
994 (Assert (not (equal #*010 #*011))) 994 (Assert (not (equal #*010 #*011)))
995 (Assert (not (equal #*010 #*))) 995 (Assert (not (equal #*010 #*)))
996 (Assert (not (equal #*110 #*010))) 996 (Assert (not (equal #*110 #*010)))
997 (Assert (not (equal #*010 #*0100))) 997 (Assert (not (equal #*010 #*0100)))
998 (Assert (not (equal #*0101 #*010))) 998 (Assert (not (equal #*0101 #*010)))
999 (Assert (equal (bit-vector 0 1 0) #*010)) 999 (Assert-equal (bit-vector 0 1 0) #*010)
1000 (Assert (equal (make-bit-vector 3 1) #*111)) 1000 (Assert-equal (make-bit-vector 3 1) #*111)
1001 (Assert (equal (make-bit-vector 3 0) #*000)) 1001 (Assert-equal (make-bit-vector 3 0) #*000)
1002 1002
1003 ;;----------------------------------------------------- 1003 ;;-----------------------------------------------------
1004 ;; Test buffer-local variables used as (ugh!) function parameters 1004 ;; Test buffer-local variables used as (ugh!) function parameters
1005 ;;----------------------------------------------------- 1005 ;;-----------------------------------------------------
1006 (make-local-variable 'test-emacs-buffer-local-variable) 1006 (make-local-variable 'test-emacs-buffer-local-variable)
1014 ;;----------------------------------------------------- 1014 ;;-----------------------------------------------------
1015 ;; Keep nulls, explicit SEPARATORS 1015 ;; Keep nulls, explicit SEPARATORS
1016 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb 1016 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb
1017 ;; I assume Hrvoje worried about the possibility of infloops. -sjt 1017 ;; I assume Hrvoje worried about the possibility of infloops. -sjt
1018 (when test-harness-risk-infloops 1018 (when test-harness-risk-infloops
1019 (Assert (equal (split-string "foo" "") '("" "f" "o" "o" ""))) 1019 (Assert-equal (split-string "foo" "") '("" "f" "o" "o" ""))
1020 (Assert (equal (split-string "foo" "^") '("" "foo"))) 1020 (Assert-equal (split-string "foo" "^") '("" "foo"))
1021 (Assert (equal (split-string "foo" "$") '("foo" "")))) 1021 (Assert-equal (split-string "foo" "$") '("foo" "")))
1022 (Assert (equal (split-string "foo,bar" ",") '("foo" "bar"))) 1022 (Assert-equal (split-string "foo,bar" ",") '("foo" "bar"))
1023 (Assert (equal (split-string ",foo,bar," ",") '("" "foo" "bar" ""))) 1023 (Assert-equal (split-string ",foo,bar," ",") '("" "foo" "bar" ""))
1024 (Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,"))) 1024 (Assert-equal (split-string ",foo,bar," "^,") '("" "foo,bar,"))
1025 (Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" ""))) 1025 (Assert-equal (split-string ",foo,bar," ",$") '(",foo,bar" ""))
1026 (Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" ""))) 1026 (Assert-equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" ""))
1027 (Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar"))) 1027 (Assert-equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar"))
1028 (Assert (equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" ""))) 1028 (Assert-equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" ""))
1029 (Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar"))) 1029 (Assert-equal (split-string "foo,,bar" ",+") '("foo" "bar"))
1030 (Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" ""))) 1030 (Assert-equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" ""))
1031 ;; Omit nulls, explicit SEPARATORS 1031 ;; Omit nulls, explicit SEPARATORS
1032 (when test-harness-risk-infloops 1032 (when test-harness-risk-infloops
1033 (Assert (equal (split-string "foo" "" t) '("f" "o" "o"))) 1033 (Assert-equal (split-string "foo" "" t) '("f" "o" "o"))
1034 (Assert (equal (split-string "foo" "^" t) '("foo"))) 1034 (Assert-equal (split-string "foo" "^" t) '("foo"))
1035 (Assert (equal (split-string "foo" "$" t) '("foo")))) 1035 (Assert-equal (split-string "foo" "$" t) '("foo")))
1036 (Assert (equal (split-string "foo,bar" "," t) '("foo" "bar"))) 1036 (Assert-equal (split-string "foo,bar" "," t) '("foo" "bar"))
1037 (Assert (equal (split-string ",foo,bar," "," t) '("foo" "bar"))) 1037 (Assert-equal (split-string ",foo,bar," "," t) '("foo" "bar"))
1038 (Assert (equal (split-string ",foo,bar," "^," t) '("foo,bar,"))) 1038 (Assert-equal (split-string ",foo,bar," "^," t) '("foo,bar,"))
1039 (Assert (equal (split-string ",foo,bar," ",$" t) '(",foo,bar"))) 1039 (Assert-equal (split-string ",foo,bar," ",$" t) '(",foo,bar"))
1040 (Assert (equal (split-string ",foo,,bar," "," t) '("foo" "bar"))) 1040 (Assert-equal (split-string ",foo,,bar," "," t) '("foo" "bar"))
1041 (Assert (equal (split-string "foo,,,bar" "," t) '("foo" "bar"))) 1041 (Assert-equal (split-string "foo,,,bar" "," t) '("foo" "bar"))
1042 (Assert (equal (split-string "foo,,bar,," "," t) '("foo" "bar"))) 1042 (Assert-equal (split-string "foo,,bar,," "," t) '("foo" "bar"))
1043 (Assert (equal (split-string "foo,,bar" ",+" t) '("foo" "bar"))) 1043 (Assert-equal (split-string "foo,,bar" ",+" t) '("foo" "bar"))
1044 (Assert (equal (split-string ",foo,,bar," ",+" t) '("foo" "bar"))) 1044 (Assert-equal (split-string ",foo,,bar," ",+" t) '("foo" "bar"))
1045 ;; "Double-default" case 1045 ;; "Double-default" case
1046 (Assert (equal (split-string "foo bar") '("foo" "bar"))) 1046 (Assert-equal (split-string "foo bar") '("foo" "bar"))
1047 (Assert (equal (split-string " foo bar ") '("foo" "bar"))) 1047 (Assert-equal (split-string " foo bar ") '("foo" "bar"))
1048 (Assert (equal (split-string " foo bar ") '("foo" "bar"))) 1048 (Assert-equal (split-string " foo bar ") '("foo" "bar"))
1049 (Assert (equal (split-string "foo bar") '("foo" "bar"))) 1049 (Assert-equal (split-string "foo bar") '("foo" "bar"))
1050 (Assert (equal (split-string "foo bar ") '("foo" "bar"))) 1050 (Assert-equal (split-string "foo bar ") '("foo" "bar"))
1051 (Assert (equal (split-string "foobar") '("foobar"))) 1051 (Assert-equal (split-string "foobar") '("foobar"))
1052 ;; Semantics are identical to "double-default" case! Fool ya? 1052 ;; Semantics are identical to "double-default" case! Fool ya?
1053 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) 1053 (Assert-equal (split-string "foo bar" nil t) '("foo" "bar"))
1054 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) 1054 (Assert-equal (split-string " foo bar " nil t) '("foo" "bar"))
1055 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) 1055 (Assert-equal (split-string " foo bar " nil t) '("foo" "bar"))
1056 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) 1056 (Assert-equal (split-string "foo bar" nil t) '("foo" "bar"))
1057 (Assert (equal (split-string "foo bar " nil t) '("foo" "bar"))) 1057 (Assert-equal (split-string "foo bar " nil t) '("foo" "bar"))
1058 (Assert (equal (split-string "foobar" nil t) '("foobar"))) 1058 (Assert-equal (split-string "foobar" nil t) '("foobar"))
1059 ;; Perverse "anti-double-default" case 1059 ;; Perverse "anti-double-default" case
1060 (Assert (equal (split-string "foo bar" split-string-default-separators) 1060 (Assert-equal (split-string "foo bar" split-string-default-separators)
1061 '("foo" "bar"))) 1061 '("foo" "bar"))
1062 (Assert (equal (split-string " foo bar " split-string-default-separators) 1062 (Assert-equal (split-string " foo bar " split-string-default-separators)
1063 '("" "foo" "bar" ""))) 1063 '("" "foo" "bar" ""))
1064 (Assert (equal (split-string " foo bar " split-string-default-separators) 1064 (Assert-equal (split-string " foo bar " split-string-default-separators)
1065 '("" "foo" "bar" ""))) 1065 '("" "foo" "bar" ""))
1066 (Assert (equal (split-string "foo bar" split-string-default-separators) 1066 (Assert-equal (split-string "foo bar" split-string-default-separators)
1067 '("foo" "bar"))) 1067 '("foo" "bar"))
1068 (Assert (equal (split-string "foo bar " split-string-default-separators) 1068 (Assert-equal (split-string "foo bar " split-string-default-separators)
1069 '("foo" "bar" ""))) 1069 '("foo" "bar" ""))
1070 (Assert (equal (split-string "foobar" split-string-default-separators) 1070 (Assert-equal (split-string "foobar" split-string-default-separators)
1071 '("foobar"))) 1071 '("foobar"))
1072 1072
1073 (Assert (not (string-match "\\(\\.\\=\\)" "."))) 1073 (Assert (not (string-match "\\(\\.\\=\\)" ".")))
1074 (Assert (string= "" (let ((str "test string")) 1074 (Assert (string= "" (let ((str "test string"))
1075 (if (string-match "^.*$" str) 1075 (if (string-match "^.*$" str)
1076 (replace-match "\\U" t nil str))))) 1076 (replace-match "\\U" t nil str)))))
1084 ;;----------------------------------------------------- 1084 ;;-----------------------------------------------------
1085 ;; Test near-text buffer functions. 1085 ;; Test near-text buffer functions.
1086 ;;----------------------------------------------------- 1086 ;;-----------------------------------------------------
1087 (with-temp-buffer 1087 (with-temp-buffer
1088 (erase-buffer) 1088 (erase-buffer)
1089 (Assert (eq (char-before) nil)) 1089 (Assert-eq (char-before) nil)
1090 (Assert (eq (char-before (point)) nil)) 1090 (Assert-eq (char-before (point)) nil)
1091 (Assert (eq (char-before (point-marker)) nil)) 1091 (Assert-eq (char-before (point-marker)) nil)
1092 (Assert (eq (char-before (point) (current-buffer)) nil)) 1092 (Assert-eq (char-before (point) (current-buffer)) nil)
1093 (Assert (eq (char-before (point-marker) (current-buffer)) nil)) 1093 (Assert-eq (char-before (point-marker) (current-buffer)) nil)
1094 (Assert (eq (char-after) nil)) 1094 (Assert-eq (char-after) nil)
1095 (Assert (eq (char-after (point)) nil)) 1095 (Assert-eq (char-after (point)) nil)
1096 (Assert (eq (char-after (point-marker)) nil)) 1096 (Assert-eq (char-after (point-marker)) nil)
1097 (Assert (eq (char-after (point) (current-buffer)) nil)) 1097 (Assert-eq (char-after (point) (current-buffer)) nil)
1098 (Assert (eq (char-after (point-marker) (current-buffer)) nil)) 1098 (Assert-eq (char-after (point-marker) (current-buffer)) nil)
1099 (Assert (eq (preceding-char) 0)) 1099 (Assert-eq (preceding-char) 0)
1100 (Assert (eq (preceding-char (current-buffer)) 0)) 1100 (Assert-eq (preceding-char (current-buffer)) 0)
1101 (Assert (eq (following-char) 0)) 1101 (Assert-eq (following-char) 0)
1102 (Assert (eq (following-char (current-buffer)) 0)) 1102 (Assert-eq (following-char (current-buffer)) 0)
1103 (insert "foobar") 1103 (insert "foobar")
1104 (Assert (eq (char-before) ?r)) 1104 (Assert-eq (char-before) ?r)
1105 (Assert (eq (char-after) nil)) 1105 (Assert-eq (char-after) nil)
1106 (Assert (eq (preceding-char) ?r)) 1106 (Assert-eq (preceding-char) ?r)
1107 (Assert (eq (following-char) 0)) 1107 (Assert-eq (following-char) 0)
1108 (goto-char (point-min)) 1108 (goto-char (point-min))
1109 (Assert (eq (char-before) nil)) 1109 (Assert-eq (char-before) nil)
1110 (Assert (eq (char-after) ?f)) 1110 (Assert-eq (char-after) ?f)
1111 (Assert (eq (preceding-char) 0)) 1111 (Assert-eq (preceding-char) 0)
1112 (Assert (eq (following-char) ?f)) 1112 (Assert-eq (following-char) ?f)
1113 ) 1113 )
1114 1114
1115 ;;----------------------------------------------------- 1115 ;;-----------------------------------------------------
1116 ;; Test plist manipulation functions. 1116 ;; Test plist manipulation functions.
1117 ;;----------------------------------------------------- 1117 ;;-----------------------------------------------------
1118 (let ((sym (make-symbol "test-symbol"))) 1118 (let ((sym (make-symbol "test-symbol")))
1119 (Assert (eq t (get* sym t t))) 1119 (Assert-eq t (get* sym t t))
1120 (Assert (eq t (get sym t t))) 1120 (Assert-eq t (get sym t t))
1121 (Assert (eq t (getf nil t t))) 1121 (Assert-eq t (getf nil t t))
1122 (Assert (eq t (plist-get nil t t))) 1122 (Assert-eq t (plist-get nil t t))
1123 (put sym 'bar 'baz) 1123 (put sym 'bar 'baz)
1124 (Assert (eq 'baz (get sym 'bar))) 1124 (Assert-eq 'baz (get sym 'bar))
1125 (Assert (eq 'baz (getf '(bar baz) 'bar))) 1125 (Assert-eq 'baz (getf '(bar baz) 'bar))
1126 (Assert (eq 'baz (getf (symbol-plist sym) 'bar))) 1126 (Assert-eq 'baz (getf (symbol-plist sym) 'bar))
1127 (Assert (eq 2 (getf '(1 2) 1))) 1127 (Assert-eq 2 (getf '(1 2) 1))
1128 (Assert (eq 4 (put sym 3 4))) 1128 (Assert-eq 4 (put sym 3 4))
1129 (Assert (eq 4 (get sym 3))) 1129 (Assert-eq 4 (get sym 3))
1130 (Assert (eq t (remprop sym 3))) 1130 (Assert-eq t (remprop sym 3))
1131 (Assert (eq nil (remprop sym 3))) 1131 (Assert-eq nil (remprop sym 3))
1132 (Assert (eq 5 (get sym 3 5))) 1132 (Assert-eq 5 (get sym 3 5))
1133 ) 1133 )
1134 1134
1135 (loop for obj in 1135 (loop for obj in
1136 (list (make-symbol "test-symbol") 1136 (list (make-symbol "test-symbol")
1137 "test-string" 1137 "test-string"
1138 (make-extent nil nil nil) 1138 (make-extent nil nil nil)
1139 (make-face 'test-face)) 1139 (make-face 'test-face))
1140 do 1140 do
1141 (Assert (eq 2 (get obj ?1 2)) obj) 1141 (Assert-eq 2 (get obj ?1 2) obj)
1142 (Assert (eq 4 (put obj ?3 4)) obj) 1142 (Assert-eq 4 (put obj ?3 4) obj)
1143 (Assert (eq 4 (get obj ?3)) obj) 1143 (Assert-eq 4 (get obj ?3) obj)
1144 (when (or (stringp obj) (symbolp obj)) 1144 (when (or (stringp obj) (symbolp obj))
1145 (Assert (equal '(?3 4) (object-plist obj)) obj)) 1145 (Assert-equal '(?3 4) (object-plist obj) obj))
1146 (Assert (eq t (remprop obj ?3)) obj) 1146 (Assert-eq t (remprop obj ?3) obj)
1147 (when (or (stringp obj) (symbolp obj)) 1147 (when (or (stringp obj) (symbolp obj))
1148 (Assert (eq '() (object-plist obj)) obj)) 1148 (Assert-eq '() (object-plist obj) obj))
1149 (Assert (eq nil (remprop obj ?3)) obj) 1149 (Assert-eq nil (remprop obj ?3) obj)
1150 (when (or (stringp obj) (symbolp obj)) 1150 (when (or (stringp obj) (symbolp obj))
1151 (Assert (eq '() (object-plist obj)) obj)) 1151 (Assert-eq '() (object-plist obj) obj))
1152 (Assert (eq 5 (get obj ?3 5)) obj) 1152 (Assert-eq 5 (get obj ?3 5) obj)
1153 ) 1153 )
1154 1154
1155 (Check-Error-Message 1155 (Check-Error-Message
1156 error "Object type has no properties" 1156 error "Object type has no properties"
1157 (get 2 'property)) 1157 (get 2 'property))
1173 (remprop (make-extent nil nil nil) 'detachable)) 1173 (remprop (make-extent nil nil nil) 'detachable))
1174 1174
1175 ;;----------------------------------------------------- 1175 ;;-----------------------------------------------------
1176 ;; Test subseq 1176 ;; Test subseq
1177 ;;----------------------------------------------------- 1177 ;;-----------------------------------------------------
1178 (Assert (equal (subseq nil 0) nil)) 1178 (Assert-equal (subseq nil 0) nil)
1179 (Assert (equal (subseq [1 2 3] 0) [1 2 3])) 1179 (Assert-equal (subseq [1 2 3] 0) [1 2 3])
1180 (Assert (equal (subseq [1 2 3] 1 -1) [2])) 1180 (Assert-equal (subseq [1 2 3] 1 -1) [2])
1181 (Assert (equal (subseq "123" 0) "123")) 1181 (Assert-equal (subseq "123" 0) "123")
1182 (Assert (equal (subseq "1234" -3 -1) "23")) 1182 (Assert-equal (subseq "1234" -3 -1) "23")
1183 (Assert (equal (subseq #*0011 0) #*0011)) 1183 (Assert-equal (subseq #*0011 0) #*0011)
1184 (Assert (equal (subseq #*0011 -3 3) #*01)) 1184 (Assert-equal (subseq #*0011 -3 3) #*01)
1185 (Assert (equal (subseq '(1 2 3) 0) '(1 2 3))) 1185 (Assert-equal (subseq '(1 2 3) 0) '(1 2 3))
1186 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4))) 1186 (Assert-equal (subseq '(1 2 3 4) -3 nil) '(2 3 4))
1187 1187
1188 (Check-Error wrong-type-argument (subseq 3 2)) 1188 (Check-Error wrong-type-argument (subseq 3 2))
1189 (Check-Error args-out-of-range (subseq [1 2 3] -42)) 1189 (Check-Error args-out-of-range (subseq [1 2 3] -42))
1190 (Check-Error args-out-of-range (subseq [1 2 3] 0 42)) 1190 (Check-Error args-out-of-range (subseq [1 2 3] 0 42))
1191 1191
1192 ;;----------------------------------------------------- 1192 ;;-----------------------------------------------------
1193 ;; Time-related tests 1193 ;; Time-related tests
1194 ;;----------------------------------------------------- 1194 ;;-----------------------------------------------------
1195 (Assert (= (length (current-time-string)) 24)) 1195 (Assert= (length (current-time-string)) 24)
1196 1196
1197 ;;----------------------------------------------------- 1197 ;;-----------------------------------------------------
1198 ;; format test 1198 ;; format test
1199 ;;----------------------------------------------------- 1199 ;;-----------------------------------------------------
1200 (Assert (string= (format "%d" 10) "10")) 1200 (Assert (string= (format "%d" 10) "10"))
1280 (Assert (string= (format "%1.3d" 10) "010")) 1280 (Assert (string= (format "%1.3d" 10) "010"))
1281 (Assert (string= (format "%3.1d" 10) " 10")) 1281 (Assert (string= (format "%3.1d" 10) " 10"))
1282 1282
1283 ;;; The following two tests used to use 1000 instead of 100, 1283 ;;; The following two tests used to use 1000 instead of 100,
1284 ;;; but that merely found buffer overflow bugs in Solaris sprintf(). 1284 ;;; but that merely found buffer overflow bugs in Solaris sprintf().
1285 (Assert (= 102 (length (format "%.100f" 3.14)))) 1285 (Assert= 102 (length (format "%.100f" 3.14)))
1286 (Assert (= 100 (length (format "%100f" 3.14)))) 1286 (Assert= 100 (length (format "%100f" 3.14)))
1287 1287
1288 ;;; Check for 64-bit cleanness on LP64 platforms. 1288 ;;; Check for 64-bit cleanness on LP64 platforms.
1289 (Assert (= (read (format "%d" most-positive-fixnum)) most-positive-fixnum)) 1289 (Assert= (read (format "%d" most-positive-fixnum)) most-positive-fixnum)
1290 (Assert (= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum)) 1290 (Assert= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum)
1291 (Assert (= (read (format "%u" most-positive-fixnum)) most-positive-fixnum)) 1291 (Assert= (read (format "%u" most-positive-fixnum)) most-positive-fixnum)
1292 (Assert (= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum)) 1292 (Assert= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum)
1293 (Assert (= (read (format "%d" most-negative-fixnum)) most-negative-fixnum)) 1293 (Assert= (read (format "%d" most-negative-fixnum)) most-negative-fixnum)
1294 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum)) 1294 (Assert= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum)
1295 1295
1296 ;; These used to crash. 1296 ;; These used to crash.
1297 (Assert (eql (read (format "%f" 1.2e+302)) 1.2e+302)) 1297 (Assert-eql (read (format "%f" 1.2e+302)) 1.2e+302)
1298 (Assert (eql (read (format "%.1000d" 1)) 1)) 1298 (Assert-eql (read (format "%.1000d" 1)) 1)
1299 1299
1300 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. 1300 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type.
1301 ;;; What to do if "%u" is used with a negative number? 1301 ;;; What to do if "%u" is used with a negative number?
1302 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an 1302 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an
1303 ;;; un-read-able number. The printed value might be useful to a human, if not 1303 ;;; un-read-able number. The printed value might be useful to a human, if not
1351 old-char) 1351 old-char)
1352 (setq old-char (aref load-file-name 0)) 1352 (setq old-char (aref load-file-name 0))
1353 (if (= new-char old-char) 1353 (if (= new-char old-char)
1354 (setq new-char ?/)) 1354 (setq new-char ?/))
1355 (aset load-file-name 0 new-char) 1355 (aset load-file-name 0 new-char)
1356 (Assert (= new-char (aref load-file-name 0)) 1356 (Assert= new-char (aref load-file-name 0)
1357 \"Check that we can modify the string value of load-file-name\")) 1357 \"Check that we can modify the string value of load-file-name\"))
1358 1358
1359 (let* ((new-load-file-name \"hi there\") 1359 (let* ((new-load-file-name \"hi there\")
1360 (load-file-name new-load-file-name)) 1360 (load-file-name new-load-file-name))
1361 (Assert (eq new-load-file-name load-file-name) 1361 (Assert-eq new-load-file-name load-file-name
1362 \"Checking that we can bind load-file-name successfully.\")) 1362 \"Checking that we can bind load-file-name successfully.\"))
1363 1363
1364 ") 1364 ")
1365 (write-region (point-min) (point-max) test-file-name nil 'quiet) 1365 (write-region (point-min) (point-max) test-file-name nil 'quiet)
1366 (set-buffer-modified-p nil) 1366 (set-buffer-modified-p nil)
1400 one-fceiling-result two-fceiling-result 1400 one-fceiling-result two-fceiling-result
1401 one-round-result two-round-result 1401 one-round-result two-round-result
1402 one-fround-result two-fround-result 1402 one-fround-result two-fround-result
1403 one-truncate-result two-truncate-result 1403 one-truncate-result two-truncate-result
1404 one-ftruncate-result two-ftruncate-result) 1404 one-ftruncate-result two-ftruncate-result)
1405 (Assert (equal one-floor-result (multiple-value-list 1405 (Assert-equal one-floor-result (multiple-value-list
1406 (floor first))) 1406 (floor first))
1407 (format "checking (floor %S) gives %S" 1407 (format "checking (floor %S) gives %S"
1408 first one-floor-result)) 1408 first one-floor-result))
1409 (Assert (equal one-floor-result (multiple-value-list 1409 (Assert-equal one-floor-result (multiple-value-list
1410 (floor first 1))) 1410 (floor first 1))
1411 (format "checking (floor %S 1) gives %S" 1411 (format "checking (floor %S 1) gives %S"
1412 first one-floor-result)) 1412 first one-floor-result))
1413 (Check-Error arith-error (floor first 0)) 1413 (Check-Error arith-error (floor first 0))
1414 (Check-Error arith-error (floor first 0.0)) 1414 (Check-Error arith-error (floor first 0.0))
1415 (Assert (equal two-floor-result (multiple-value-list 1415 (Assert-equal two-floor-result (multiple-value-list
1416 (floor first second))) 1416 (floor first second))
1417 (format 1417 (format
1418 "checking (floor %S %S) gives %S" 1418 "checking (floor %S %S) gives %S"
1419 first second two-floor-result)) 1419 first second two-floor-result))
1420 (Assert (equal (cl-floor first second) 1420 (Assert-equal (cl-floor first second)
1421 (multiple-value-list (floor first second))) 1421 (multiple-value-list (floor first second))
1422 (format 1422 (format
1423 "checking (floor %S %S) gives the same as the old code" 1423 "checking (floor %S %S) gives the same as the old code"
1424 first second)) 1424 first second))
1425 (Assert (equal one-ffloor-result (multiple-value-list 1425 (Assert-equal one-ffloor-result (multiple-value-list
1426 (ffloor first))) 1426 (ffloor first))
1427 (format "checking (ffloor %S) gives %S" 1427 (format "checking (ffloor %S) gives %S"
1428 first one-ffloor-result)) 1428 first one-ffloor-result))
1429 (Assert (equal one-ffloor-result (multiple-value-list 1429 (Assert-equal one-ffloor-result (multiple-value-list
1430 (ffloor first 1))) 1430 (ffloor first 1))
1431 (format "checking (ffloor %S 1) gives %S" 1431 (format "checking (ffloor %S 1) gives %S"
1432 first one-ffloor-result)) 1432 first one-ffloor-result))
1433 (Check-Error arith-error (ffloor first 0)) 1433 (Check-Error arith-error (ffloor first 0))
1434 (Check-Error arith-error (ffloor first 0.0)) 1434 (Check-Error arith-error (ffloor first 0.0))
1435 (Assert (equal two-ffloor-result (multiple-value-list 1435 (Assert-equal two-ffloor-result (multiple-value-list
1436 (ffloor first second))) 1436 (ffloor first second))
1437 (format "checking (ffloor %S %S) gives %S" 1437 (format "checking (ffloor %S %S) gives %S"
1438 first second two-ffloor-result)) 1438 first second two-ffloor-result))
1439 (Assert (equal one-ceiling-result (multiple-value-list 1439 (Assert-equal one-ceiling-result (multiple-value-list
1440 (ceiling first))) 1440 (ceiling first))
1441 (format "checking (ceiling %S) gives %S" 1441 (format "checking (ceiling %S) gives %S"
1442 first one-ceiling-result)) 1442 first one-ceiling-result))
1443 (Assert (equal one-ceiling-result (multiple-value-list 1443 (Assert-equal one-ceiling-result (multiple-value-list
1444 (ceiling first 1))) 1444 (ceiling first 1))
1445 (format "checking (ceiling %S 1) gives %S" 1445 (format "checking (ceiling %S 1) gives %S"
1446 first one-ceiling-result)) 1446 first one-ceiling-result))
1447 (Check-Error arith-error (ceiling first 0)) 1447 (Check-Error arith-error (ceiling first 0))
1448 (Check-Error arith-error (ceiling first 0.0)) 1448 (Check-Error arith-error (ceiling first 0.0))
1449 (Assert (equal two-ceiling-result (multiple-value-list 1449 (Assert-equal two-ceiling-result (multiple-value-list
1450 (ceiling first second))) 1450 (ceiling first second))
1451 (format "checking (ceiling %S %S) gives %S" 1451 (format "checking (ceiling %S %S) gives %S"
1452 first second two-ceiling-result)) 1452 first second two-ceiling-result))
1453 (Assert (equal (cl-ceiling first second) 1453 (Assert-equal (cl-ceiling first second)
1454 (multiple-value-list (ceiling first second))) 1454 (multiple-value-list (ceiling first second))
1455 (format 1455 (format
1456 "checking (ceiling %S %S) gives the same as the old code" 1456 "checking (ceiling %S %S) gives the same as the old code"
1457 first second)) 1457 first second))
1458 (Assert (equal one-fceiling-result (multiple-value-list 1458 (Assert-equal one-fceiling-result (multiple-value-list
1459 (fceiling first))) 1459 (fceiling first))
1460 (format "checking (fceiling %S) gives %S" 1460 (format "checking (fceiling %S) gives %S"
1461 first one-fceiling-result)) 1461 first one-fceiling-result))
1462 (Assert (equal one-fceiling-result (multiple-value-list 1462 (Assert-equal one-fceiling-result (multiple-value-list
1463 (fceiling first 1))) 1463 (fceiling first 1))
1464 (format "checking (fceiling %S 1) gives %S" 1464 (format "checking (fceiling %S 1) gives %S"
1465 first one-fceiling-result)) 1465 first one-fceiling-result))
1466 (Check-Error arith-error (fceiling first 0)) 1466 (Check-Error arith-error (fceiling first 0))
1467 (Check-Error arith-error (fceiling first 0.0)) 1467 (Check-Error arith-error (fceiling first 0.0))
1468 (Assert (equal two-fceiling-result (multiple-value-list 1468 (Assert-equal two-fceiling-result (multiple-value-list
1469 (fceiling first second))) 1469 (fceiling first second))
1470 (format "checking (fceiling %S %S) gives %S" 1470 (format "checking (fceiling %S %S) gives %S"
1471 first second two-fceiling-result)) 1471 first second two-fceiling-result))
1472 (Assert (equal one-round-result (multiple-value-list 1472 (Assert-equal one-round-result (multiple-value-list
1473 (round first))) 1473 (round first))
1474 (format "checking (round %S) gives %S" 1474 (format "checking (round %S) gives %S"
1475 first one-round-result)) 1475 first one-round-result))
1476 (Assert (equal one-round-result (multiple-value-list 1476 (Assert-equal one-round-result (multiple-value-list
1477 (round first 1))) 1477 (round first 1))
1478 (format "checking (round %S 1) gives %S" 1478 (format "checking (round %S 1) gives %S"
1479 first one-round-result)) 1479 first one-round-result))
1480 (Check-Error arith-error (round first 0)) 1480 (Check-Error arith-error (round first 0))
1481 (Check-Error arith-error (round first 0.0)) 1481 (Check-Error arith-error (round first 0.0))
1482 (Assert (equal two-round-result (multiple-value-list 1482 (Assert-equal two-round-result (multiple-value-list
1483 (round first second))) 1483 (round first second))
1484 (format "checking (round %S %S) gives %S" 1484 (format "checking (round %S %S) gives %S"
1485 first second two-round-result)) 1485 first second two-round-result))
1486 (Assert (equal one-fround-result (multiple-value-list 1486 (Assert-equal one-fround-result (multiple-value-list
1487 (fround first))) 1487 (fround first))
1488 (format "checking (fround %S) gives %S" 1488 (format "checking (fround %S) gives %S"
1489 first one-fround-result)) 1489 first one-fround-result))
1490 (Assert (equal one-fround-result (multiple-value-list 1490 (Assert-equal one-fround-result (multiple-value-list
1491 (fround first 1))) 1491 (fround first 1))
1492 (format "checking (fround %S 1) gives %S" 1492 (format "checking (fround %S 1) gives %S"
1493 first one-fround-result)) 1493 first one-fround-result))
1494 (Check-Error arith-error (fround first 0)) 1494 (Check-Error arith-error (fround first 0))
1495 (Check-Error arith-error (fround first 0.0)) 1495 (Check-Error arith-error (fround first 0.0))
1496 (Assert (equal two-fround-result (multiple-value-list 1496 (Assert-equal two-fround-result (multiple-value-list
1497 (fround first second))) 1497 (fround first second))
1498 (format "checking (fround %S %S) gives %S" 1498 (format "checking (fround %S %S) gives %S"
1499 first second two-fround-result)) 1499 first second two-fround-result))
1500 (Assert (equal (cl-round first second) 1500 (Assert-equal (cl-round first second)
1501 (multiple-value-list (round first second))) 1501 (multiple-value-list (round first second))
1502 (format 1502 (format
1503 "checking (round %S %S) gives the same as the old code" 1503 "checking (round %S %S) gives the same as the old code"
1504 first second)) 1504 first second))
1505 (Assert (equal one-truncate-result (multiple-value-list 1505 (Assert-equal one-truncate-result (multiple-value-list
1506 (truncate first))) 1506 (truncate first))
1507 (format "checking (truncate %S) gives %S" 1507 (format "checking (truncate %S) gives %S"
1508 first one-truncate-result)) 1508 first one-truncate-result))
1509 (Assert (equal one-truncate-result (multiple-value-list 1509 (Assert-equal one-truncate-result (multiple-value-list
1510 (truncate first 1))) 1510 (truncate first 1))
1511 (format "checking (truncate %S 1) gives %S" 1511 (format "checking (truncate %S 1) gives %S"
1512 first one-truncate-result)) 1512 first one-truncate-result))
1513 (Check-Error arith-error (truncate first 0)) 1513 (Check-Error arith-error (truncate first 0))
1514 (Check-Error arith-error (truncate first 0.0)) 1514 (Check-Error arith-error (truncate first 0.0))
1515 (Assert (equal two-truncate-result (multiple-value-list 1515 (Assert-equal two-truncate-result (multiple-value-list
1516 (truncate first second))) 1516 (truncate first second))
1517 (format "checking (truncate %S %S) gives %S" 1517 (format "checking (truncate %S %S) gives %S"
1518 first second two-truncate-result)) 1518 first second two-truncate-result))
1519 (Assert (equal (cl-truncate first second) 1519 (Assert-equal (cl-truncate first second)
1520 (multiple-value-list (truncate first second))) 1520 (multiple-value-list (truncate first second))
1521 (format 1521 (format
1522 "checking (truncate %S %S) gives the same as the old code" 1522 "checking (truncate %S %S) gives the same as the old code"
1523 first second)) 1523 first second))
1524 (Assert (equal one-ftruncate-result (multiple-value-list 1524 (Assert-equal one-ftruncate-result (multiple-value-list
1525 (ftruncate first))) 1525 (ftruncate first))
1526 (format "checking (ftruncate %S) gives %S" 1526 (format "checking (ftruncate %S) gives %S"
1527 first one-ftruncate-result)) 1527 first one-ftruncate-result))
1528 (Assert (equal one-ftruncate-result (multiple-value-list 1528 (Assert-equal one-ftruncate-result (multiple-value-list
1529 (ftruncate first 1))) 1529 (ftruncate first 1))
1530 (format "checking (ftruncate %S 1) gives %S" 1530 (format "checking (ftruncate %S 1) gives %S"
1531 first one-ftruncate-result)) 1531 first one-ftruncate-result))
1532 (Check-Error arith-error (ftruncate first 0)) 1532 (Check-Error arith-error (ftruncate first 0))
1533 (Check-Error arith-error (ftruncate first 0.0)) 1533 (Check-Error arith-error (ftruncate first 0.0))
1534 (Assert (equal two-ftruncate-result (multiple-value-list 1534 (Assert-equal two-ftruncate-result (multiple-value-list
1535 (ftruncate first second))) 1535 (ftruncate first second))
1536 (format "checking (ftruncate %S %S) gives %S" 1536 (format "checking (ftruncate %S %S) gives %S"
1537 first second two-ftruncate-result))) 1537 first second two-ftruncate-result)))
1538 (Assert-rounding-floating (pie ee) 1538 (Assert-rounding-floating (pie ee)
1539 (let ((pie-type (type-of pie))) 1539 (let ((pie-type (type-of pie)))
1540 (assert (eq pie-type (type-of ee)) t 1540 (assert (eq pie-type (type-of ee)) t
1998 (= 2 (length (multiple-value-list 1998 (= 2 (length (multiple-value-list
1999 (multiple-value-prog1 (floor pi) "hi there")))) 1999 (multiple-value-prog1 (floor pi) "hi there"))))
2000 "Checking #'multiple-value-prog1 passes back multiple values") 2000 "Checking #'multiple-value-prog1 passes back multiple values")
2001 (multiple-value-bind (floored remainder this-is-nil) 2001 (multiple-value-bind (floored remainder this-is-nil)
2002 (floor pi 1.0) 2002 (floor pi 1.0)
2003 (Assert (= floored 3) 2003 (Assert= floored 3
2004 "Checking floored bound correctly") 2004 "Checking floored bound correctly")
2005 (Assert (eql remainder (- pi 3.0)) 2005 (Assert-eql remainder (- pi 3.0)
2006 "Checking remainder bound correctly") 2006 "Checking remainder bound correctly")
2007 (Assert (null this-is-nil) 2007 (Assert (null this-is-nil)
2008 "Checking trailing arg bound but nil")) 2008 "Checking trailing arg bound but nil"))
2009 (let ((ey 40000) 2009 (let ((ey 40000)
2010 (bee "this is a string") 2010 (bee "this is a string")
2011 (cee #s(hash-table size 256 data (969 ?\xF9)))) 2011 (cee #s(hash-table size 256 data (969 ?\xF9))))
2012 (multiple-value-setq (ey bee cee) 2012 (multiple-value-setq (ey bee cee)
2013 (ffloor e 1.0)) 2013 (ffloor e 1.0))
2014 (Assert (eql 2.0 ey) "Checking ey set correctly") 2014 (Assert-eql 2.0 ey "Checking ey set correctly")
2015 (Assert (eql bee (- e 2.0)) "Checking bee set correctly") 2015 (Assert-eql bee (- e 2.0) "Checking bee set correctly")
2016 (Assert (null cee) "Checking cee set to nil correctly")) 2016 (Assert (null cee) "Checking cee set to nil correctly"))
2017 (Assert 2017 (Assert
2018 (= 3 (length (multiple-value-list (eval '(values nil t pi))))) 2018 (= 3 (length (multiple-value-list (eval '(values nil t pi)))))
2019 "Checking #'eval passes back multiple values") 2019 "Checking #'eval passes back multiple values")
2020 (Assert 2020 (Assert
2093 with res = (make-string 96 ?\x20) 2093 with res = (make-string 96 ?\x20)
2094 for int-char from #x20 to #x7f 2094 for int-char from #x20 to #x7f
2095 for char being each element in-ref res 2095 for char being each element in-ref res
2096 do (setf char (int-to-char int-char)) 2096 do (setf char (int-to-char int-char))
2097 finally return res))) 2097 finally return res)))
2098 (Assert (equalp "hi there" "Hi There") 2098 (Assert-equalp "hi there" "Hi There"
2099 "checking equalp isn't case-sensitive") 2099 "checking equalp isn't case-sensitive")
2100 (Assert (equalp 99 99.0) 2100 (Assert-equalp 99 99.0
2101 "checking equalp compares numerical values of different types") 2101 "checking equalp compares numerical values of different types")
2102 (Assert (null (equalp 99 ?c)) 2102 (Assert (null (equalp 99 ?c))
2103 "checking equalp does not convert characters to numbers") 2103 "checking equalp does not convert characters to numbers")
2104 ;; Fixed in Hg d0ea57eb3de4. 2104 ;; Fixed in Hg d0ea57eb3de4.
2105 (Assert (null (equalp "hi there" [hi there])) 2105 (Assert (null (equalp "hi there" [hi there]))
2106 "checking equalp doesn't error with string and non-string") 2106 "checking equalp doesn't error with string and non-string")
2107 (Assert (eq t (equalp "ABCDEEFGH\u00CDJ" string-variable)) 2107 (Assert-eq t (equalp "ABCDEEFGH\u00CDJ" string-variable)
2108 "checking #'equalp is case-insensitive with an upcased constant") 2108 "checking #'equalp is case-insensitive with an upcased constant")
2109 (Assert (eq t (equalp "abcdeefgh\xedj" string-variable)) 2109 (Assert-eq t (equalp "abcdeefgh\xedj" string-variable)
2110 "checking #'equalp is case-insensitive with a downcased constant") 2110 "checking #'equalp is case-insensitive with a downcased constant")
2111 (Assert (eq t (equalp string-variable string-variable)) 2111 (Assert-eq t (equalp string-variable string-variable)
2112 "checking #'equalp works when handed the same string twice") 2112 "checking #'equalp works when handed the same string twice")
2113 (Assert (eq t (equalp string-variable "aBcDeeFgH\u00Edj")) 2113 (Assert-eq t (equalp string-variable "aBcDeeFgH\u00Edj")
2114 "check #'equalp is case-insensitive with a variable-cased constant") 2114 "check #'equalp is case-insensitive with a variable-cased constant")
2115 (Assert (eq t (equalp "" (bit-vector))) 2115 (Assert-eq t (equalp "" (bit-vector))
2116 "check empty string and empty bit-vector are #'equalp.") 2116 "check empty string and empty bit-vector are #'equalp.")
2117 (Assert (eq t (equalp (string) (bit-vector))) 2117 (Assert-eq t (equalp (string) (bit-vector))
2118 "check empty string and empty bit-vector are #'equalp, no constants") 2118 "check empty string and empty bit-vector are #'equalp, no constants")
2119 (Assert (eq t (equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e))) 2119 (Assert-eq t (equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e))
2120 "check string and vector with same contents #'equalp") 2120 "check string and vector with same contents #'equalp")
2121 (Assert (eq t (equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) 2121 (Assert-eq t (equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e)
2122 (vector ?h ?i ?\ ?t ?h ?e ?r ?e))) 2122 (vector ?h ?i ?\ ?t ?h ?e ?r ?e))
2123 "check string and vector with same contents #'equalp, no constants") 2123 "check string and vector with same contents #'equalp, no constants")
2124 (Assert (eq t (equalp [?h ?i ?\ ?t ?h ?e ?r ?e] 2124 (Assert-eq t (equalp [?h ?i ?\ ?t ?h ?e ?r ?e]
2125 (string ?h ?i ?\ ?t ?h ?e ?r ?e))) 2125 (string ?h ?i ?\ ?t ?h ?e ?r ?e))
2126 "check string and vector with same contents #'equalp, vector constant") 2126 "check string and vector with same contents #'equalp, vector constant")
2127 (Assert (eq t (equalp [0 1.0 0.0 0 1] 2127 (Assert-eq t (equalp [0 1.0 0.0 0 1]
2128 (bit-vector 0 1 0 0 1))) 2128 (bit-vector 0 1 0 0 1))
2129 "check vector and bit-vector with same contents #'equalp,\ 2129 "check vector and bit-vector with same contents #'equalp,\
2130 vector constant") 2130 vector constant")
2131 (Assert (eq t (equalp #*01001 2131 (Assert-eq t (equalp #*01001
2132 (vector 0 1.0 0.0 0 1))) 2132 (vector 0 1.0 0.0 0 1))
2133 "check vector and bit-vector with same contents #'equalp,\ 2133 "check vector and bit-vector with same contents #'equalp,\
2134 bit-vector constant") 2134 bit-vector constant")
2135 (Assert (eq t (equalp ?\u00E9 Eacute-character)) 2135 (Assert-eq t (equalp ?\u00E9 Eacute-character)
2136 "checking characters are case-insensitive, one constant") 2136 "checking characters are case-insensitive, one constant")
2137 (Assert (eq nil (equalp ?\u00E9 (aref (format "%c" ?a) 0))) 2137 (Assert-eq nil (equalp ?\u00E9 (aref (format "%c" ?a) 0))
2138 "checking distinct characters are not equalp, one constant") 2138 "checking distinct characters are not equalp, one constant")
2139 (Assert (eq t (equalp t (and))) 2139 (Assert-eq t (equalp t (and))
2140 "checking symbols are correctly #'equalp") 2140 "checking symbols are correctly #'equalp")
2141 (Assert (eq nil (equalp t (or nil '#:t))) 2141 (Assert-eq nil (equalp t (or nil '#:t))
2142 "checking distinct symbols with the same name are not #'equalp") 2142 "checking distinct symbols with the same name are not #'equalp")
2143 (Assert (eq t (equalp #s(char-table type generic data (?\u0080 "hi-there")) 2143 (Assert-eq t (equalp #s(char-table type generic data (?\u0080 "hi-there"))
2144 (let ((aragh (make-char-table 'generic))) 2144 (let ((aragh (make-char-table 'generic)))
2145 (put-char-table ?\u0080 "hi-there" aragh) 2145 (put-char-table ?\u0080 "hi-there" aragh)
2146 aragh))) 2146 aragh))
2147 "checking #'equalp succeeds correctly, char-tables") 2147 "checking #'equalp succeeds correctly, char-tables")
2148 (Assert (eq nil (equalp #s(char-table type generic data (?\u0080 "hi-there")) 2148 (Assert-eq nil (equalp #s(char-table type generic data (?\u0080 "hi-there"))
2149 (let ((aragh (make-char-table 'generic))) 2149 (let ((aragh (make-char-table 'generic)))
2150 (put-char-table ?\u0080 "HI-THERE" aragh) 2150 (put-char-table ?\u0080 "HI-THERE" aragh)
2151 aragh))) 2151 aragh))
2152 "checking #'equalp fails correctly, char-tables")) 2152 "checking #'equalp fails correctly, char-tables"))
2153 2153
2154 ;; There are more tests available for equalp here: 2154 ;; There are more tests available for equalp here:
2155 ;; 2155 ;;
2156 ;; http://www.parhasard.net/xemacs/equalp-tests.el 2156 ;; http://www.parhasard.net/xemacs/equalp-tests.el