Mercurial > hg > xemacs-beta
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 |