Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 5136:0f66906b6e37

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically -------------------- ChangeLog entries follow: -------------------- lisp/ChangeLog addition: 2010-03-12 Ben Wing <ben@xemacs.org> * test-harness.el (test-harness-from-buffer): Undo change of e.g. (Assert (equalp ...)) to (Assert-equalp ...). Get rid of `Assert-equalp' and friends, `Assert-test', and `Assert-test-not'. Instead, make `Assert' smart enough to do the equivalent functionality when an expression like (Assert (equalp ...)) is seen. tests/ChangeLog addition: 2010-03-12 Ben Wing <ben@xemacs.org> * automated/base64-tests.el (bt-base64-encode-string): * automated/base64-tests.el (bt-base64-decode-string): * automated/base64-tests.el (for): * automated/byte-compiler-tests.el: * automated/byte-compiler-tests.el (before-and-after-compile-equal): * automated/case-tests.el (downcase-string): * automated/case-tests.el (uni-mappings): * automated/ccl-tests.el (ccl-test-normal-expr): * automated/ccl-tests.el (ccl-test-map-instructions): * automated/ccl-tests.el (ccl-test-suites): * automated/database-tests.el (delete-database-files): * automated/extent-tests.el (let): * automated/extent-tests.el (insert): * automated/extent-tests.el (props): * automated/file-tests.el: * automated/file-tests.el (for): * automated/hash-table-tests.el (test): * automated/hash-table-tests.el (for): * automated/hash-table-tests.el (ht): * automated/hash-table-tests.el (iterations): * automated/hash-table-tests.el (h1): * automated/hash-table-tests.el (equal): * automated/hash-table-tests.el (=): * automated/lisp-tests.el: * automated/lisp-tests.el (eq): * automated/lisp-tests.el (test-setq): * automated/lisp-tests.el (my-vector): * automated/lisp-tests.el (x): * automated/lisp-tests.el (equal): * automated/lisp-tests.el (y): * automated/lisp-tests.el (featurep): * automated/lisp-tests.el (=): * automated/lisp-tests.el (six): * automated/lisp-tests.el (three): * automated/lisp-tests.el (one): * automated/lisp-tests.el (two): * automated/lisp-tests.el (five): * automated/lisp-tests.el (test1): * automated/lisp-tests.el (division-test): * automated/lisp-tests.el (for): * automated/lisp-tests.el (check-function-argcounts): * automated/lisp-tests.el (z): * automated/lisp-tests.el (eql): * automated/lisp-tests.el (test-harness-risk-infloops): * automated/lisp-tests.el (erase-buffer): * automated/lisp-tests.el (sym): * automated/lisp-tests.el (new-char): * automated/lisp-tests.el (new-load-file-name): * automated/lisp-tests.el (cl-floor): * automated/lisp-tests.el (foo): * automated/md5-tests.el (lambda): * automated/md5-tests.el (large-string): * automated/md5-tests.el (mapcar): * automated/md5-tests.el (insert): * automated/mule-tests.el: * automated/mule-tests.el (test-chars): * automated/mule-tests.el (existing-file-name): * automated/mule-tests.el (featurep): * automated/query-coding-tests.el (featurep): * automated/regexp-tests.el: * automated/regexp-tests.el (insert): * automated/regexp-tests.el (Assert): * automated/regexp-tests.el (=): * automated/regexp-tests.el (featurep): * automated/regexp-tests.el (text): * automated/regexp-tests.el (text1): * automated/regexp-tests.el ("aáa"): * automated/regexp-tests.el (eql): * automated/search-tests.el (insert): * automated/search-tests.el (featurep): * automated/search-tests.el (let): * automated/search-tests.el (boundp): * automated/symbol-tests.el: * automated/symbol-tests.el (name): * automated/symbol-tests.el (check-weak-list-unique): * automated/symbol-tests.el (string): * automated/symbol-tests.el (list): * automated/symbol-tests.el (foo): * automated/symbol-tests.el (eq): * automated/symbol-tests.el (fresh-keyword-name): * automated/symbol-tests.el (print-gensym): * automated/symbol-tests.el (mysym): * automated/syntax-tests.el (test-forward-word): * automated/syntax-tests.el (test-backward-word): * automated/syntax-tests.el (test-syntax-table): * automated/syntax-tests.el (with-syntax-table): * automated/syntax-tests.el (Skip-Test-Unless): * automated/syntax-tests.el (with): * automated/tag-tests.el (testfile): * automated/weak-tests.el (w): * automated/weak-tests.el (p): * automated/weak-tests.el (a): Undo change of e.g. (Assert (equalp ...)) to (Assert-equalp ...). Get rid of `Assert-equalp' and friends, `Assert-test', and `Assert-test-not'. Instead, make `Assert' smart enough to do the equivalent functionality when an expression like (Assert (equalp ...)) is seen.
author Ben Wing <ben@xemacs.org>
date Fri, 12 Mar 2010 18:27:51 -0600
parents 9624523604c5
children 000287f8053b
comparison
equal deleted inserted replaced
5113:b2dcf6a6d8ab 5136:0f66906b6e37
1 ;; Copyright (C) 1998 Free Software Foundation, Inc. -*- coding: iso-8859-1 -*- 1 ;; Copyright (C) 1998 Free Software Foundation, Inc. -*- coding: iso-8859-1 -*-
2 ;; Copyright (C) 2010 Ben Wing.
2 3
3 ;; Author: Martin Buchholz <martin@xemacs.org> 4 ;; Author: Martin Buchholz <martin@xemacs.org>
4 ;; Maintainer: Martin Buchholz <martin@xemacs.org> 5 ;; Maintainer: Martin Buchholz <martin@xemacs.org>
5 ;; Created: 1998 6 ;; Created: 1998
6 ;; Keywords: tests 7 ;; Keywords: tests
40 41
41 (Check-Error wrong-number-of-arguments (setq setq-test-foo)) 42 (Check-Error wrong-number-of-arguments (setq setq-test-foo))
42 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar)) 43 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar))
43 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo)) 44 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo))
44 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar)) 45 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar))
45 (Assert-eq (setq) nil) 46 (Assert (eq (setq) nil))
46 (Assert-eq (setq-default) nil) 47 (Assert (eq (setq-default) nil))
47 (Assert-eq (setq setq-test-foo 42) 42) 48 (Assert (eq (setq setq-test-foo 42) 42))
48 (Assert-eq (setq-default setq-test-foo 42) 42) 49 (Assert (eq (setq-default setq-test-foo 42) 42))
49 (Assert-eq (setq setq-test-foo 42 setq-test-bar 99) 99) 50 (Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99))
50 (Assert-eq (setq-default setq-test-foo 42 setq-test-bar 99) 99) 51 (Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99))
51 52
52 (macrolet ((test-setq (expected-result &rest body) 53 (macrolet ((test-setq (expected-result &rest body)
53 `(progn 54 `(progn
54 (defun test-setq-fun () ,@body) 55 (defun test-setq-fun () ,@body)
55 (Assert-eq ,expected-result (test-setq-fun)) 56 (Assert (eq ,expected-result (test-setq-fun)))
56 (byte-compile 'test-setq-fun) 57 (byte-compile 'test-setq-fun)
57 (Assert-eq ,expected-result (test-setq-fun))))) 58 (Assert (eq ,expected-result (test-setq-fun))))))
58 (test-setq nil (setq)) 59 (test-setq nil (setq))
59 (test-setq nil (setq-default)) 60 (test-setq nil (setq-default))
60 (test-setq 42 (setq test-setq-var 42)) 61 (test-setq 42 (setq test-setq-var 42))
61 (test-setq 42 (setq-default test-setq-var 42)) 62 (test-setq 42 (setq-default test-setq-var 42))
62 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42)) 63 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42))
67 (my-bit-vector (bit-vector 1 0 1 0)) 68 (my-bit-vector (bit-vector 1 0 1 0))
68 (my-string "1234") 69 (my-string "1234")
69 (my-list '(1 2 3 4))) 70 (my-list '(1 2 3 4)))
70 71
71 ;;(Assert (fooooo)) ;; Generate Other failure 72 ;;(Assert (fooooo)) ;; Generate Other failure
72 ;;(Assert-eq 1 2) ;; Generate Assertion failure 73 ;;(Assert (eq 1 2)) ;; Generate Assertion failure
73 74
74 (dolist (sequence (list my-vector my-bit-vector my-string my-list)) 75 (dolist (sequence (list my-vector my-bit-vector my-string my-list))
75 (Assert (sequencep sequence)) 76 (Assert (sequencep sequence))
76 (Assert-eq 4 (length sequence))) 77 (Assert (eq 4 (length sequence))))
77 78
78 (dolist (array (list my-vector my-bit-vector my-string)) 79 (dolist (array (list my-vector my-bit-vector my-string))
79 (Assert (arrayp array))) 80 (Assert (arrayp array)))
80 81
81 (Assert-eq (elt my-vector 0) 1) 82 (Assert (eq (elt my-vector 0) 1))
82 (Assert-eq (elt my-bit-vector 0) 1) 83 (Assert (eq (elt my-bit-vector 0) 1))
83 (Assert-eq (elt my-string 0) ?1) 84 (Assert (eq (elt my-string 0) ?1))
84 (Assert-eq (elt my-list 0) 1) 85 (Assert (eq (elt my-list 0) 1))
85 86
86 (fillarray my-vector 5) 87 (fillarray my-vector 5)
87 (fillarray my-bit-vector 1) 88 (fillarray my-bit-vector 1)
88 (fillarray my-string ?5) 89 (fillarray my-string ?5)
89 90
90 (dolist (array (list my-vector my-bit-vector)) 91 (dolist (array (list my-vector my-bit-vector))
91 (Assert-eq 4 (length array))) 92 (Assert (eq 4 (length array))))
92 93
93 (Assert-eq (elt my-vector 0) 5) 94 (Assert (eq (elt my-vector 0) 5))
94 (Assert-eq (elt my-bit-vector 0) 1) 95 (Assert (eq (elt my-bit-vector 0) 1))
95 (Assert-eq (elt my-string 0) ?5) 96 (Assert (eq (elt my-string 0) ?5))
96 97
97 (Assert-eq (elt my-vector 3) 5) 98 (Assert (eq (elt my-vector 3) 5))
98 (Assert-eq (elt my-bit-vector 3) 1) 99 (Assert (eq (elt my-bit-vector 3) 1))
99 (Assert-eq (elt my-string 3) ?5) 100 (Assert (eq (elt my-string 3) ?5))
100 101
101 (fillarray my-bit-vector 0) 102 (fillarray my-bit-vector 0)
102 (Assert-eq 4 (length my-bit-vector)) 103 (Assert (eq 4 (length my-bit-vector)))
103 (Assert-eq (elt my-bit-vector 2) 0) 104 (Assert (eq (elt my-bit-vector 2) 0))
104 ) 105 )
105 106
106 (defun make-circular-list (length) 107 (defun make-circular-list (length)
107 "Create evil emacs-crashing circular list of length LENGTH" 108 "Create evil emacs-crashing circular list of length LENGTH"
108 (let ((circular-list 109 (let ((circular-list
122 (dolist (length '(1 2 3 4 1000 2000)) 123 (dolist (length '(1 2 3 4 1000 2000))
123 (Check-Error circular-list (nconc (make-circular-list length) 'foo)) 124 (Check-Error circular-list (nconc (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) (make-circular-list length) 'foo))
125 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo))) 126 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo)))
126 127
127 (Assert-eq (nconc) nil) 128 (Assert (eq (nconc) nil))
128 (Assert-eq (nconc nil) nil) 129 (Assert (eq (nconc nil) nil))
129 (Assert-eq (nconc nil nil) nil) 130 (Assert (eq (nconc nil nil) nil))
130 (Assert-eq (nconc nil nil nil) nil) 131 (Assert (eq (nconc nil nil nil) nil))
131 132
132 (let ((x (make-list-012))) (Assert-eq (nconc nil x) x)) 133 (let ((x (make-list-012))) (Assert (eq (nconc nil x) x)))
133 (let ((x (make-list-012))) (Assert-eq (nconc x nil) x)) 134 (let ((x (make-list-012))) (Assert (eq (nconc 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 nil x nil) x)))
135 (let ((x (make-list-012))) (Assert-eq (nconc x) x)) 136 (let ((x (make-list-012))) (Assert (eq (nconc x) x)))
136 (let ((x (make-list-012))) (Assert-eq (nconc x (make-circular-list 3)) x)) 137 (let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x)))
137 138
138 (Assert-equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6)) 139 (Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6)))
139 140
140 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) 141 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil)))
141 (Assert-eq (length y) 6) 142 (Assert (eq (length y) 6))
142 (Assert-eq (nth 3 y) 3)) 143 (Assert (eq (nth 3 y) 3)))
143 144
144 ;;----------------------------------------------------- 145 ;;-----------------------------------------------------
145 ;; Test `last' 146 ;; Test `last'
146 ;;----------------------------------------------------- 147 ;;-----------------------------------------------------
147 (Check-Error wrong-type-argument (last 'foo)) 148 (Check-Error wrong-type-argument (last 'foo))
148 (Check-Error wrong-number-of-arguments (last)) 149 (Check-Error wrong-number-of-arguments (last))
149 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1)) 150 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1))
150 (Check-Error circular-list (last (make-circular-list 1))) 151 (Check-Error circular-list (last (make-circular-list 1)))
151 (Check-Error circular-list (last (make-circular-list 2000))) 152 (Check-Error circular-list (last (make-circular-list 2000)))
152 (let ((x (list 0 1 2 3))) 153 (let ((x (list 0 1 2 3)))
153 (Assert-eq (last nil) nil) 154 (Assert (eq (last nil) nil))
154 (Assert-eq (last x 0) nil) 155 (Assert (eq (last x 0) nil))
155 (Assert-eq (last x ) (cdddr x)) 156 (Assert (eq (last x ) (cdddr x)))
156 (Assert-eq (last x 1) (cdddr x)) 157 (Assert (eq (last x 1) (cdddr x)))
157 (Assert-eq (last x 2) (cddr x)) 158 (Assert (eq (last x 2) (cddr x)))
158 (Assert-eq (last x 3) (cdr x)) 159 (Assert (eq (last x 3) (cdr x)))
159 (Assert-eq (last x 4) x) 160 (Assert (eq (last x 4) x))
160 (Assert-eq (last x 9) x) 161 (Assert (eq (last x 9) x))
161 (Assert-eq (last '(1 . 2) 0) 2) 162 (Assert (eq (last '(1 . 2) 0) 2))
162 ) 163 )
163 164
164 ;;----------------------------------------------------- 165 ;;-----------------------------------------------------
165 ;; Test `butlast' and `nbutlast' 166 ;; Test `butlast' and `nbutlast'
166 ;;----------------------------------------------------- 167 ;;-----------------------------------------------------
176 (Check-Error circular-list (nbutlast (make-circular-list 2000))) 177 (Check-Error circular-list (nbutlast (make-circular-list 2000)))
177 178
178 (let* ((x (list 0 1 2 3)) 179 (let* ((x (list 0 1 2 3))
179 (y (butlast x)) 180 (y (butlast x))
180 (z (nbutlast x))) 181 (z (nbutlast x)))
181 (Assert-eq z x) 182 (Assert (eq z x))
182 (Assert (not (eq y x))) 183 (Assert (not (eq y x)))
183 (Assert-equal y '(0 1 2)) 184 (Assert (equal y '(0 1 2)))
184 (Assert-equal z y)) 185 (Assert (equal z y)))
185 186
186 (let* ((x (list 0 1 2 3 4)) 187 (let* ((x (list 0 1 2 3 4))
187 (y (butlast x 2)) 188 (y (butlast x 2))
188 (z (nbutlast x 2))) 189 (z (nbutlast x 2)))
189 (Assert-eq z x) 190 (Assert (eq z x))
190 (Assert (not (eq y x))) 191 (Assert (not (eq y x)))
191 (Assert-equal y '(0 1 2)) 192 (Assert (equal y '(0 1 2)))
192 (Assert-equal z y)) 193 (Assert (equal z y)))
193 194
194 (let* ((x (list 0 1 2 3)) 195 (let* ((x (list 0 1 2 3))
195 (y (butlast x 0)) 196 (y (butlast x 0))
196 (z (nbutlast x 0))) 197 (z (nbutlast x 0)))
197 (Assert-eq z x) 198 (Assert (eq z x))
198 (Assert (not (eq y x))) 199 (Assert (not (eq y x)))
199 (Assert-equal y '(0 1 2 3)) 200 (Assert (equal y '(0 1 2 3)))
200 (Assert-equal z y)) 201 (Assert (equal z y)))
201 202
202 (Assert-eq (butlast '(x)) nil) 203 (Assert (eq (butlast '(x)) nil))
203 (Assert-eq (nbutlast '(x)) nil) 204 (Assert (eq (nbutlast '(x)) nil))
204 (Assert-eq (butlast '()) nil) 205 (Assert (eq (butlast '()) nil))
205 (Assert-eq (nbutlast '()) nil) 206 (Assert (eq (nbutlast '()) nil))
206 207
207 ;;----------------------------------------------------- 208 ;;-----------------------------------------------------
208 ;; Test `copy-list' 209 ;; Test `copy-list'
209 ;;----------------------------------------------------- 210 ;;-----------------------------------------------------
210 (Check-Error wrong-type-argument (copy-list 'foo)) 211 (Check-Error wrong-type-argument (copy-list 'foo))
211 (Check-Error wrong-number-of-arguments (copy-list)) 212 (Check-Error wrong-number-of-arguments (copy-list))
212 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) 213 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1))
213 (Check-Error circular-list (copy-list (make-circular-list 1))) 214 (Check-Error circular-list (copy-list (make-circular-list 1)))
214 (Check-Error circular-list (copy-list (make-circular-list 2000))) 215 (Check-Error circular-list (copy-list (make-circular-list 2000)))
215 (Assert-eq '() (copy-list '())) 216 (Assert (eq '() (copy-list '())))
216 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) 217 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3)))
217 (let ((y (copy-list x))) 218 (let ((y (copy-list x)))
218 (Assert (and (equal x y) (not (eq x y)))))) 219 (Assert (and (equal x y) (not (eq x y))))))
219 220
220 ;;----------------------------------------------------- 221 ;;-----------------------------------------------------
221 ;; Arithmetic operations 222 ;; Arithmetic operations
222 ;;----------------------------------------------------- 223 ;;-----------------------------------------------------
223 224
224 ;; Test `+' 225 ;; Test `+'
225 (Assert-eq (+ 1 1) 2) 226 (Assert (eq (+ 1 1) 2))
226 (Assert= (+ 1.0 1.0) 2.0) 227 (Assert (= (+ 1.0 1.0) 2.0))
227 (Assert= (+ 1.0 3.0 0.0) 4.0) 228 (Assert (= (+ 1.0 3.0 0.0) 4.0))
228 (Assert= (+ 1 1.0) 2.0) 229 (Assert (= (+ 1 1.0) 2.0))
229 (Assert= (+ 1.0 1) 2.0) 230 (Assert (= (+ 1.0 1) 2.0))
230 (Assert= (+ 1.0 1 1) 3.0) 231 (Assert (= (+ 1.0 1 1) 3.0))
231 (Assert= (+ 1 1 1.0) 3.0) 232 (Assert (= (+ 1 1 1.0) 3.0))
232 (if (featurep 'bignum) 233 (if (featurep 'bignum)
233 (progn 234 (progn
234 (Assert (bignump (1+ most-positive-fixnum))) 235 (Assert (bignump (1+ most-positive-fixnum)))
235 (Assert-eq most-positive-fixnum (1- (1+ most-positive-fixnum))) 236 (Assert (eq most-positive-fixnum (1- (1+ most-positive-fixnum))))
236 (Assert (bignump (+ most-positive-fixnum 1))) 237 (Assert (bignump (+ most-positive-fixnum 1)))
237 (Assert-eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1)) 238 (Assert (eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1)))
238 (Assert= (1+ most-positive-fixnum) (- most-negative-fixnum)) 239 (Assert (= (1+ most-positive-fixnum) (- most-negative-fixnum)))
239 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum) 240 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum)
240 3)))) 241 3))))
241 (Assert-eq (1+ most-positive-fixnum) most-negative-fixnum) 242 (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum))
242 (Assert-eq (+ most-positive-fixnum 1) most-negative-fixnum)) 243 (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum)))
243 244
244 (when (featurep 'ratio) 245 (when (featurep 'ratio)
245 (let ((threefourths (read "3/4")) 246 (let ((threefourths (read "3/4"))
246 (threehalfs (read "3/2")) 247 (threehalfs (read "3/2"))
247 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) 248 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
248 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum)) 249 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum))
249 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) 250 (negone (div (1+ most-positive-fixnum) most-negative-fixnum)))
250 (Assert= negone -1) 251 (Assert (= negone -1))
251 (Assert= threehalfs (+ threefourths threefourths)) 252 (Assert (= threehalfs (+ threefourths threefourths)))
252 (Assert (zerop (+ bigpos bigneg))))) 253 (Assert (zerop (+ bigpos bigneg)))))
253 254
254 ;; Test `-' 255 ;; Test `-'
255 (Check-Error wrong-number-of-arguments (-)) 256 (Check-Error wrong-number-of-arguments (-))
256 (Assert-eq (- 0) 0) 257 (Assert (eq (- 0) 0))
257 (Assert-eq (- 1) -1) 258 (Assert (eq (- 1) -1))
258 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) 259 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1)))
259 (Assert= (+ 1 one) 2) 260 (Assert (= (+ 1 one) 2))
260 (Assert= (+ one) 1) 261 (Assert (= (+ one) 1))
261 (Assert= (+ one) one) 262 (Assert (= (+ one) one))
262 (Assert= (- one) -1) 263 (Assert (= (- one) -1))
263 (Assert= (- one one) 0) 264 (Assert (= (- one one) 0))
264 (Assert= (- one one one) -1) 265 (Assert (= (- one one one) -1))
265 (Assert= (- 0 one) -1) 266 (Assert (= (- 0 one) -1))
266 (Assert= (- 0 one one) -2) 267 (Assert (= (- 0 one one) -2))
267 (Assert= (+ one 1) 2) 268 (Assert (= (+ one 1) 2))
268 (dolist (zero '(0 0.0 ?\0)) 269 (dolist (zero '(0 0.0 ?\0))
269 (Assert= (+ 1 zero) 1 zero) 270 (Assert (= (+ 1 zero) 1) zero)
270 (Assert= (+ zero 1) 1 zero) 271 (Assert (= (+ zero 1) 1) zero)
271 (Assert= (- zero) zero zero) 272 (Assert (= (- zero) zero) zero)
272 (Assert= (- zero) 0 zero) 273 (Assert (= (- zero) 0) zero)
273 (Assert= (- zero zero) 0 zero) 274 (Assert (= (- zero zero) 0) zero)
274 (Assert= (- zero one one) -2 zero))) 275 (Assert (= (- zero one one) -2) zero)))
275 276
276 (Assert= (- 1.5 1) .5) 277 (Assert (= (- 1.5 1) .5))
277 (Assert= (- 1 1.5) (- .5)) 278 (Assert (= (- 1 1.5) (- .5)))
278 279
279 (if (featurep 'bignum) 280 (if (featurep 'bignum)
280 (progn 281 (progn
281 (Assert (bignump (1- most-negative-fixnum))) 282 (Assert (bignump (1- most-negative-fixnum)))
282 (Assert-eq most-negative-fixnum (1+ (1- most-negative-fixnum))) 283 (Assert (eq most-negative-fixnum (1+ (1- most-negative-fixnum))))
283 (Assert (bignump (- most-negative-fixnum 1))) 284 (Assert (bignump (- most-negative-fixnum 1)))
284 (Assert-eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1)) 285 (Assert (eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1)))
285 (Assert= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2)) 286 (Assert (= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2)))
286 (Assert-eq (- (- most-positive-fixnum most-negative-fixnum) 287 (Assert (eq (- (- most-positive-fixnum most-negative-fixnum)
287 (* 2 most-positive-fixnum)) 288 (* 2 most-positive-fixnum))
288 1)) 289 1)))
289 (Assert-eq (1- most-negative-fixnum) most-positive-fixnum) 290 (Assert (eq (1- most-negative-fixnum) most-positive-fixnum))
290 (Assert-eq (- most-negative-fixnum 1) most-positive-fixnum)) 291 (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum)))
291 292
292 (when (featurep 'ratio) 293 (when (featurep 'ratio)
293 (let ((threefourths (read "3/4")) 294 (let ((threefourths (read "3/4"))
294 (threehalfs (read "3/2")) 295 (threehalfs (read "3/2"))
295 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) 296 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum)))
296 (bigneg (div most-positive-fixnum most-negative-fixnum)) 297 (bigneg (div most-positive-fixnum most-negative-fixnum))
297 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) 298 (negone (div (1+ most-positive-fixnum) most-negative-fixnum)))
298 (Assert= (- negone) 1) 299 (Assert (= (- negone) 1))
299 (Assert= threefourths (- threehalfs threefourths)) 300 (Assert (= threefourths (- threehalfs threefourths)))
300 (Assert= (- bigpos bigneg) 2))) 301 (Assert (= (- bigpos bigneg) 2))))
301 302
302 ;; Test `/' 303 ;; Test `/'
303 304
304 ;; Test division by zero errors 305 ;; Test division by zero errors
305 (dolist (zero '(0 0.0 ?\0)) 306 (dolist (zero '(0 0.0 ?\0))
310 (Check-Error arith-error (/ n1 n2 zero))))) 311 (Check-Error arith-error (/ n1 n2 zero)))))
311 312
312 ;; Other tests for `/' 313 ;; Other tests for `/'
313 (Check-Error wrong-number-of-arguments (/)) 314 (Check-Error wrong-number-of-arguments (/))
314 (let (x) 315 (let (x)
315 (Assert= (/ (setq x 2)) 0) 316 (Assert (= (/ (setq x 2)) 0))
316 (Assert= (/ (setq x 2.0)) 0.5)) 317 (Assert (= (/ (setq x 2.0)) 0.5)))
317 318
318 (dolist (six '(6 6.0 ?\06)) 319 (dolist (six '(6 6.0 ?\06))
319 (dolist (two '(2 2.0 ?\02)) 320 (dolist (two '(2 2.0 ?\02))
320 (dolist (three '(3 3.0 ?\03)) 321 (dolist (three '(3 3.0 ?\03))
321 (Assert= (/ six two) three (list six two three))))) 322 (Assert (= (/ six two) three) (list six two three)))))
322 323
323 (dolist (three '(3 3.0 ?\03)) 324 (dolist (three '(3 3.0 ?\03))
324 (Assert= (/ three 2.0) 1.5 three)) 325 (Assert (= (/ three 2.0) 1.5) three))
325 (dolist (two '(2 2.0 ?\02)) 326 (dolist (two '(2 2.0 ?\02))
326 (Assert= (/ 3.0 two) 1.5 two)) 327 (Assert (= (/ 3.0 two) 1.5) two))
327 328
328 (when (featurep 'bignum) 329 (when (featurep 'bignum)
329 (let* ((million 1000000) 330 (let* ((million 1000000)
330 (billion (* million 1000)) ;; American, not British, billion 331 (billion (* million 1000)) ;; American, not British, billion
331 (trillion (* billion 1000))) 332 (trillion (* billion 1000)))
332 (Assert= (/ billion 1000) (/ trillion million) million 1000000.0) 333 (Assert (= (/ billion 1000) (/ trillion million) million 1000000.0))
333 (Assert= (/ billion -1000) (/ trillion (- million)) (- million)) 334 (Assert (= (/ billion -1000) (/ trillion (- million)) (- million)))
334 (Assert= (/ trillion 1000) billion 1000000000.0) 335 (Assert (= (/ trillion 1000) billion 1000000000.0))
335 (Assert= (/ trillion -1000) (- billion) -1000000000.0) 336 (Assert (= (/ trillion -1000) (- billion) -1000000000.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 (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0))))
338 339
339 (when (featurep 'ratio) 340 (when (featurep 'ratio)
340 (let ((half (div 1 2)) 341 (let ((half (div 1 2))
341 (fivefourths (div 5 4)) 342 (fivefourths (div 5 4))
342 (fivehalfs (div 5 2))) 343 (fivehalfs (div 5 2)))
343 (Assert= half (read "3000000000/6000000000")) 344 (Assert (= half (read "3000000000/6000000000")))
344 (Assert= (/ fivehalfs fivefourths) 2) 345 (Assert (= (/ fivehalfs fivefourths) 2))
345 (Assert= (/ fivefourths fivehalfs) half) 346 (Assert (= (/ fivefourths fivehalfs) half))
346 (Assert= (- half) (read "-3000000000/6000000000")) 347 (Assert (= (- half) (read "-3000000000/6000000000")))
347 (Assert= (/ fivehalfs (- fivefourths)) -2) 348 (Assert (= (/ fivehalfs (- fivefourths)) -2))
348 (Assert= (/ (- fivefourths) fivehalfs) (- half)))) 349 (Assert (= (/ (- fivefourths) fivehalfs) (- half)))))
349 350
350 ;; Test `*' 351 ;; Test `*'
351 (Assert= 1 (*)) 352 (Assert (= 1 (*)))
352 353
353 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) 354 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
354 (Assert= 1 (* one) one)) 355 (Assert (= 1 (* one)) one))
355 356
356 (dolist (two '(2 2.0 ?\02)) 357 (dolist (two '(2 2.0 ?\02))
357 (Assert= 2 (* two) two)) 358 (Assert (= 2 (* two)) two))
358 359
359 (dolist (six '(6 6.0 ?\06)) 360 (dolist (six '(6 6.0 ?\06))
360 (dolist (two '(2 2.0 ?\02)) 361 (dolist (two '(2 2.0 ?\02))
361 (dolist (three '(3 3.0 ?\03)) 362 (dolist (three '(3 3.0 ?\03))
362 (Assert= (* three two) six (list three two six))))) 363 (Assert (= (* three two) six) (list three two six)))))
363 364
364 (dolist (three '(3 3.0 ?\03)) 365 (dolist (three '(3 3.0 ?\03))
365 (dolist (two '(2 2.0 ?\02)) 366 (dolist (two '(2 2.0 ?\02))
366 (Assert= (* 1.5 two) three (list two three)) 367 (Assert (= (* 1.5 two) three) (list two three))
367 (dolist (five '(5 5.0 ?\05)) 368 (dolist (five '(5 5.0 ?\05))
368 (Assert= 30 (* five two three) (list five two three))))) 369 (Assert (= 30 (* five two three)) (list five two three)))))
369 370
370 (when (featurep 'bignum) 371 (when (featurep 'bignum)
371 (let ((64K 65536)) 372 (let ((64K 65536))
372 (Assert= (* 64K 64K) (read "4294967296")) 373 (Assert (= (* 64K 64K) (read "4294967296")))
373 (Assert= (* (- 64K) 64K) (read "-4294967296")) 374 (Assert (= (* (- 64K) 64K) (read "-4294967296")))
374 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum)))) 375 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum))))
375 376
376 (when (featurep 'ratio) 377 (when (featurep 'ratio)
377 (let ((half (div 1 2)) 378 (let ((half (div 1 2))
378 (fivefourths (div 5 4)) 379 (fivefourths (div 5 4))
379 (twofifths (div 2 5))) 380 (twofifths (div 2 5)))
380 (Assert= (* fivefourths twofifths) half) 381 (Assert (= (* fivefourths twofifths) half))
381 (Assert= (* half twofifths) (read "3/15")))) 382 (Assert (= (* half twofifths) (read "3/15")))))
382 383
383 ;; Test `+' 384 ;; Test `+'
384 (Assert= 0 (+)) 385 (Assert (= 0 (+)))
385 386
386 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) 387 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
387 (Assert= 1 (+ one) one)) 388 (Assert (= 1 (+ one)) one))
388 389
389 (dolist (two '(2 2.0 ?\02)) 390 (dolist (two '(2 2.0 ?\02))
390 (Assert= 2 (+ two) two)) 391 (Assert (= 2 (+ two)) two))
391 392
392 (dolist (five '(5 5.0 ?\05)) 393 (dolist (five '(5 5.0 ?\05))
393 (dolist (two '(2 2.0 ?\02)) 394 (dolist (two '(2 2.0 ?\02))
394 (dolist (three '(3 3.0 ?\03)) 395 (dolist (three '(3 3.0 ?\03))
395 (Assert= (+ three two) five (list three two five)) 396 (Assert (= (+ three two) five) (list three two five))
396 (Assert= 10 (+ five two three) (list five two three))))) 397 (Assert (= 10 (+ five two three)) (list five two three)))))
397 398
398 ;; Test `max', `min' 399 ;; Test `max', `min'
399 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) 400 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
400 (Assert= one (max one) one) 401 (Assert (= one (max one)) one)
401 (Assert= one (max one one) one) 402 (Assert (= one (max one one)) one)
402 (Assert= one (max one one one) one) 403 (Assert (= one (max one one one)) one)
403 (Assert= one (min one) one) 404 (Assert (= one (min one)) one)
404 (Assert= one (min one one) one) 405 (Assert (= one (min one one)) one)
405 (Assert= one (min one one one) one) 406 (Assert (= one (min one one one)) one)
406 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) 407 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2)))
407 (Assert= one (min one two) (list one two)) 408 (Assert (= one (min one two)) (list one two))
408 (Assert= one (min one two two) (list one two)) 409 (Assert (= one (min one two two)) (list one two))
409 (Assert= one (min two two one) (list one two)) 410 (Assert (= one (min two two one)) (list one two))
410 (Assert= two (max one two) (list one two)) 411 (Assert (= two (max one two)) (list one two))
411 (Assert= two (max one two two) (list one two)) 412 (Assert (= two (max one two two)) (list one two))
412 (Assert= two (max two two one) (list one two)))) 413 (Assert (= two (max two two one)) (list one two))))
413 414
414 (when (featurep 'bignum) 415 (when (featurep 'bignum)
415 (let ((big (1+ most-positive-fixnum)) 416 (let ((big (1+ most-positive-fixnum))
416 (small (1- most-negative-fixnum))) 417 (small (1- most-negative-fixnum)))
417 (Assert= big (max 1 1000000.0 most-positive-fixnum big)) 418 (Assert (= big (max 1 1000000.0 most-positive-fixnum big)))
418 (Assert= small (min -1 -1000000.0 most-negative-fixnum small)))) 419 (Assert (= small (min -1 -1000000.0 most-negative-fixnum small)))))
419 420
420 (when (featurep 'ratio) 421 (when (featurep 'ratio)
421 (let* ((big (1+ most-positive-fixnum)) 422 (let* ((big (1+ most-positive-fixnum))
422 (small (1- most-negative-fixnum)) 423 (small (1- most-negative-fixnum))
423 (bigr (div (* 5 (1+ most-positive-fixnum)) 4)) 424 (bigr (div (* 5 (1+ most-positive-fixnum)) 4))
424 (smallr (- bigr))) 425 (smallr (- bigr)))
425 (Assert= bigr (max 1 1000000.0 most-positive-fixnum big bigr)) 426 (Assert (= bigr (max 1 1000000.0 most-positive-fixnum big bigr)))
426 (Assert= smallr (min -1 -1000000.0 most-negative-fixnum small smallr)))) 427 (Assert (= smallr (min -1 -1000000.0 most-negative-fixnum small smallr)))))
427 428
428 ;; The byte compiler has special handling for these constructs: 429 ;; The byte compiler has special handling for these constructs:
429 (let ((three 3) (five 5)) 430 (let ((three 3) (five 5))
430 (Assert= (+ three five 1) 9) 431 (Assert (= (+ three five 1) 9))
431 (Assert= (+ 1 three five) 9) 432 (Assert (= (+ 1 three five) 9))
432 (Assert= (+ three five -1) 7) 433 (Assert (= (+ three five -1) 7))
433 (Assert= (+ -1 three five) 7) 434 (Assert (= (+ -1 three five) 7))
434 (Assert= (+ three 1) 4) 435 (Assert (= (+ three 1) 4))
435 (Assert= (+ three -1) 2) 436 (Assert (= (+ three -1) 2))
436 (Assert= (+ -1 three) 2) 437 (Assert (= (+ -1 three) 2))
437 (Assert= (+ -1 three) 2) 438 (Assert (= (+ -1 three) 2))
438 (Assert= (- three five 1) -3) 439 (Assert (= (- three five 1) -3))
439 (Assert= (- 1 three five) -7) 440 (Assert (= (- 1 three five) -7))
440 (Assert= (- three five -1) -1) 441 (Assert (= (- three five -1) -1))
441 (Assert= (- -1 three five) -9) 442 (Assert (= (- -1 three five) -9))
442 (Assert= (- three 1) 2) 443 (Assert (= (- three 1) 2))
443 (Assert= (- three 2 1) 0) 444 (Assert (= (- three 2 1) 0))
444 (Assert= (- 2 three 1) -2) 445 (Assert (= (- 2 three 1) -2))
445 (Assert= (- three -1) 4) 446 (Assert (= (- three -1) 4))
446 (Assert= (- three 0) 3) 447 (Assert (= (- three 0) 3))
447 (Assert= (- three 0 five) -2) 448 (Assert (= (- three 0 five) -2))
448 (Assert= (- 0 three 0 five) -8) 449 (Assert (= (- 0 three 0 five) -8))
449 (Assert= (- 0 three five) -8) 450 (Assert (= (- 0 three five) -8))
450 (Assert= (* three 2) 6) 451 (Assert (= (* three 2) 6))
451 (Assert= (* three -1 five) -15) 452 (Assert (= (* three -1 five) -15))
452 (Assert= (* three 1 five) 15) 453 (Assert (= (* three 1 five) 15))
453 (Assert= (* three 0 five) 0) 454 (Assert (= (* three 0 five) 0))
454 (Assert= (* three 2 five) 30) 455 (Assert (= (* three 2 five) 30))
455 (Assert= (/ three 1) 3) 456 (Assert (= (/ three 1) 3))
456 (Assert= (/ three -1) -3) 457 (Assert (= (/ three -1) -3))
457 (Assert= (/ (* five five) 2 2) 6) 458 (Assert (= (/ (* five five) 2 2) 6))
458 (Assert= (/ 64 five 2) 6)) 459 (Assert (= (/ 64 five 2) 6)))
459 460
460 461
461 ;;----------------------------------------------------- 462 ;;-----------------------------------------------------
462 ;; Logical bit-twiddling operations 463 ;; Logical bit-twiddling operations
463 ;;----------------------------------------------------- 464 ;;-----------------------------------------------------
464 (Assert= (logxor) 0) 465 (Assert (= (logxor) 0))
465 (Assert= (logior) 0) 466 (Assert (= (logior) 0))
466 (Assert= (logand) -1) 467 (Assert (= (logand) -1))
467 468
468 (Check-Error wrong-type-argument (logxor 3.0)) 469 (Check-Error wrong-type-argument (logxor 3.0))
469 (Check-Error wrong-type-argument (logior 3.0)) 470 (Check-Error wrong-type-argument (logior 3.0))
470 (Check-Error wrong-type-argument (logand 3.0)) 471 (Check-Error wrong-type-argument (logand 3.0))
471 472
472 (dolist (three '(3 ?\03)) 473 (dolist (three '(3 ?\03))
473 (Assert-eq 3 (logand three) three) 474 (Assert (eq 3 (logand three)) three)
474 (Assert-eq 3 (logxor three) three) 475 (Assert (eq 3 (logxor three)) three)
475 (Assert-eq 3 (logior three) three) 476 (Assert (eq 3 (logior three)) three)
476 (Assert-eq 3 (logand three three) three) 477 (Assert (eq 3 (logand three three)) three)
477 (Assert-eq 0 (logxor three three) three) 478 (Assert (eq 0 (logxor three three)) three)
478 (Assert-eq 3 (logior three three)) three) 479 (Assert (eq 3 (logior three three))) three)
479 480
480 (dolist (one `(1 ?\01 ,(Int-to-Marker 1))) 481 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
481 (dolist (two '(2 ?\02)) 482 (dolist (two '(2 ?\02))
482 (Assert-eq 0 (logand one two) (list one two)) 483 (Assert (eq 0 (logand one two)) (list one two))
483 (Assert-eq 3 (logior one two) (list one two)) 484 (Assert (eq 3 (logior one two)) (list one two))
484 (Assert-eq 3 (logxor one two) (list one two))) 485 (Assert (eq 3 (logxor one two)) (list one two)))
485 (dolist (three '(3 ?\03)) 486 (dolist (three '(3 ?\03))
486 (Assert-eq 1 (logand one three) (list one three)) 487 (Assert (eq 1 (logand one three)) (list one three))
487 (Assert-eq 3 (logior one three) (list one three)) 488 (Assert (eq 3 (logior one three)) (list one three))
488 (Assert-eq 2 (logxor one three) (list one three)))) 489 (Assert (eq 2 (logxor one three)) (list one three))))
489 490
490 ;;----------------------------------------------------- 491 ;;-----------------------------------------------------
491 ;; Test `%', mod 492 ;; Test `%', mod
492 ;;----------------------------------------------------- 493 ;;-----------------------------------------------------
493 (Check-Error wrong-number-of-arguments (%)) 494 (Check-Error wrong-number-of-arguments (%))
499 (Check-Error wrong-number-of-arguments (mod 1 2 3)) 500 (Check-Error wrong-number-of-arguments (mod 1 2 3))
500 501
501 (Check-Error wrong-type-argument (% 10.0 2)) 502 (Check-Error wrong-type-argument (% 10.0 2))
502 (Check-Error wrong-type-argument (% 10 2.0)) 503 (Check-Error wrong-type-argument (% 10 2.0))
503 504
504 (flet ((test1 (x) (Assert-eql x (+ (% x 17) (* (/ x 17) 17)) x)) 505 (flet ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x))
505 (test2 (x) (Assert-eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17)) x)) 506 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
506 (test3 (x) (Assert-eql x (+ (% (- x) 17) (* (/ (- x) 17) 17)) x)) 507 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x))
507 (test4 (x) (Assert-eql (% x -17) (- (% (- x) 17)) x)) 508 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x))
508 (test5 (x) (Assert-eql (% x -17) (% (- x) 17)) x)) 509 (test5 (x) (Assert (eql (% x -17) (% (- x) 17))) x))
509 (test1 most-negative-fixnum) 510 (test1 most-negative-fixnum)
510 (if (featurep 'bignum) 511 (if (featurep 'bignum)
511 (progn 512 (progn
512 (test2 most-negative-fixnum) 513 (test2 most-negative-fixnum)
513 (test4 most-negative-fixnum)) 514 (test4 most-negative-fixnum))
525 (test4 x)))) 526 (test4 x))))
526 527
527 (macrolet 528 (macrolet
528 ((division-test (seven) 529 ((division-test (seven)
529 `(progn 530 `(progn
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 (Assert (eq (% (- ,seven) -2) -1))
534 535
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 (Assert (eq (% (- ,seven) -4) -3))
539 540
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 (Assert (eq (% -35 (- ,seven)) 0))
544 545
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 (Assert (eq (mod (- ,seven) -2) -1))
549 550
550 (Assert-eq (mod ,seven 4) 3) 551 (Assert (eq (mod ,seven 4) 3))
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) 1))
553 (Assert-eq (mod (- ,seven) -4) -3) 554 (Assert (eq (mod (- ,seven) -4) -3))
554 555
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 (Assert (eq (mod -35 (- ,seven)) 0))
559 560
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 (Assert (= (mod (- ,seven) -2.0) -1.0))
564 565
565 (Assert= (mod ,seven 4.0) 3.0) 566 (Assert (= (mod ,seven 4.0) 3.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) 1.0))
568 (Assert= (mod (- ,seven) -4.0) -3.0) 569 (Assert (= (mod (- ,seven) -4.0) -3.0))
569 570
570 (Assert-eq (% 0 ,seven) 0) 571 (Assert (eq (% 0 ,seven) 0))
571 (Assert-eq (% 0 (- ,seven)) 0) 572 (Assert (eq (% 0 (- ,seven)) 0))
572 573
573 (Assert-eq (mod 0 ,seven) 0) 574 (Assert (eq (mod 0 ,seven) 0))
574 (Assert-eq (mod 0 (- ,seven)) 0) 575 (Assert (eq (mod 0 (- ,seven)) 0))
575 576
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 (Assert (= (mod 0.0 (- ,seven)) 0.0)))))
578 579
579 (division-test 7) 580 (division-test 7)
580 (division-test ?\07) 581 (division-test ?\07)
581 (division-test (Int-to-Marker 7))) 582 (division-test (Int-to-Marker 7)))
582 583
598 (Check-Error wrong-number-of-arguments (>=)) 599 (Check-Error wrong-number-of-arguments (>=))
599 (Check-Error wrong-number-of-arguments (/=)) 600 (Check-Error wrong-number-of-arguments (/=))
600 601
601 ;; One argument always yields t 602 ;; One argument always yields t
602 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do 603 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do
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 (Assert (eq t (/= x)) x)
609 ) 610 )
610 611
611 ;; Type checking 612 ;; Type checking
612 (Check-Error wrong-type-argument (= 'foo 1)) 613 (Check-Error wrong-type-argument (= 'foo 1))
613 (Check-Error wrong-type-argument (<= 'foo 1)) 614 (Check-Error wrong-type-argument (<= 'foo 1))
631 (Assert (not (> one one)) one) 632 (Assert (not (> one one)) one)
632 (Assert (<= one one two two) (list one two)) 633 (Assert (<= one one two two) (list one two))
633 (Assert (not (< one one two two)) (list one two)) 634 (Assert (not (< one one two two)) (list one two))
634 (Assert (>= two two one one) (list one two)) 635 (Assert (>= two two one one) (list one two))
635 (Assert (not (> two two one one)) (list one two)) 636 (Assert (not (> two two one one)) (list one two))
636 (Assert= one one one one) 637 (Assert (= one one one) one)
637 (Assert (not (= one one one two)) (list one two)) 638 (Assert (not (= one one one two)) (list one two))
638 (Assert (not (/= one two one)) (list one two)) 639 (Assert (not (/= one two one)) (list one two))
639 )) 640 ))
640 641
641 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) 642 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
652 (Assert (not (> one one)) one) 653 (Assert (not (> one one)) one)
653 (Assert (<= one one two two) (list one two)) 654 (Assert (<= one one two two) (list one two))
654 (Assert (not (< one one two two)) (list one two)) 655 (Assert (not (< one one two two)) (list one two))
655 (Assert (>= two two one one) (list one two)) 656 (Assert (>= two two one one) (list one two))
656 (Assert (not (> two two one one)) (list one two)) 657 (Assert (not (> two two one one)) (list one two))
657 (Assert= one one one one) 658 (Assert (= one one one) one)
658 (Assert (not (= one one one two)) (list one two)) 659 (Assert (not (= one one one two)) (list one two))
659 (Assert (not (/= one two one)) (list one two)) 660 (Assert (not (/= one two one)) (list one two))
660 )) 661 ))
661 662
662 ;; ad-hoc 663 ;; ad-hoc
672 (Assert (<= 1 2 3 4 5 6 6)) 673 (Assert (<= 1 2 3 4 5 6 6))
673 (Assert (not (< 1 2 3 4 5 6 6))) 674 (Assert (not (< 1 2 3 4 5 6 6)))
674 (Assert (<= 1 1)) 675 (Assert (<= 1 1))
675 676
676 (Assert (not (eq (point) (point-marker)))) 677 (Assert (not (eq (point) (point-marker))))
677 (Assert= 1 (Int-to-Marker 1)) 678 (Assert (= 1 (Int-to-Marker 1)))
678 (Assert= (point) (point-marker)) 679 (Assert (= (point) (point-marker)))
679 680
680 (when (featurep 'bignum) 681 (when (featurep 'bignum)
681 (let ((big1 (1+ most-positive-fixnum)) 682 (let ((big1 (1+ most-positive-fixnum))
682 (big2 (* 10 most-positive-fixnum)) 683 (big2 (* 10 most-positive-fixnum))
683 (small1 (1- most-negative-fixnum)) 684 (small1 (1- most-negative-fixnum))
698 (big2 (div (* 5 most-positive-fixnum) 2)) 699 (big2 (div (* 5 most-positive-fixnum) 2))
699 (big3 (div (* 7 most-positive-fixnum) 2)) 700 (big3 (div (* 7 most-positive-fixnum) 2))
700 (small1 (div (* 10 most-negative-fixnum) 4)) 701 (small1 (div (* 10 most-negative-fixnum) 4))
701 (small2 (div (* 5 most-negative-fixnum) 2)) 702 (small2 (div (* 5 most-negative-fixnum) 2))
702 (small3 (div (* 7 most-negative-fixnum) 2))) 703 (small3 (div (* 7 most-negative-fixnum) 2)))
703 (Assert= big1 big2) 704 (Assert (= big1 big2))
704 (Assert= small1 small2) 705 (Assert (= small1 small2))
705 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1 706 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1
706 big3)) 707 big3))
707 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum 708 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum
708 big1 big2 big3)) 709 big1 big2 big3))
709 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1 710 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1
735 delete old-delete 736 delete old-delete
736 delq old-delq 737 delq old-delq
737 remassoc remassq remrassoc remrassq)) 738 remassoc remassq remrassoc remrassq))
738 739
739 (let ((x '((1 . 2) 3 (4 . 5)))) 740 (let ((x '((1 . 2) 3 (4 . 5))))
740 (Assert-eq (assoc 1 x) (car x)) 741 (Assert (eq (assoc 1 x) (car x)))
741 (Assert-eq (assq 1 x) (car x)) 742 (Assert (eq (assq 1 x) (car x)))
742 (Assert-eq (rassoc 1 x) nil) 743 (Assert (eq (rassoc 1 x) nil))
743 (Assert-eq (rassq 1 x) nil) 744 (Assert (eq (rassq 1 x) nil))
744 (Assert-eq (assoc 2 x) nil) 745 (Assert (eq (assoc 2 x) nil))
745 (Assert-eq (assq 2 x) nil) 746 (Assert (eq (assq 2 x) nil))
746 (Assert-eq (rassoc 2 x) (car x)) 747 (Assert (eq (rassoc 2 x) (car x)))
747 (Assert-eq (rassq 2 x) (car x)) 748 (Assert (eq (rassq 2 x) (car x)))
748 (Assert-eq (assoc 3 x) nil) 749 (Assert (eq (assoc 3 x) nil))
749 (Assert-eq (assq 3 x) nil) 750 (Assert (eq (assq 3 x) nil))
750 (Assert-eq (rassoc 3 x) nil) 751 (Assert (eq (rassoc 3 x) nil))
751 (Assert-eq (rassq 3 x) nil) 752 (Assert (eq (rassq 3 x) nil))
752 (Assert-eq (assoc 4 x) (caddr x)) 753 (Assert (eq (assoc 4 x) (caddr x)))
753 (Assert-eq (assq 4 x) (caddr x)) 754 (Assert (eq (assq 4 x) (caddr x)))
754 (Assert-eq (rassoc 4 x) nil) 755 (Assert (eq (rassoc 4 x) nil))
755 (Assert-eq (rassq 4 x) nil) 756 (Assert (eq (rassq 4 x) nil))
756 (Assert-eq (assoc 5 x) nil) 757 (Assert (eq (assoc 5 x) nil))
757 (Assert-eq (assq 5 x) nil) 758 (Assert (eq (assq 5 x) nil))
758 (Assert-eq (rassoc 5 x) (caddr x)) 759 (Assert (eq (rassoc 5 x) (caddr x)))
759 (Assert-eq (rassq 5 x) (caddr x)) 760 (Assert (eq (rassq 5 x) (caddr x)))
760 (Assert-eq (assoc 6 x) nil) 761 (Assert (eq (assoc 6 x) nil))
761 (Assert-eq (assq 6 x) nil) 762 (Assert (eq (assq 6 x) nil))
762 (Assert-eq (rassoc 6 x) nil) 763 (Assert (eq (rassoc 6 x) nil))
763 (Assert-eq (rassq 6 x) nil)) 764 (Assert (eq (rassq 6 x) nil)))
764 765
765 (let ((x '(("1" . "2") "3" ("4" . "5")))) 766 (let ((x '(("1" . "2") "3" ("4" . "5"))))
766 (Assert-eq (assoc "1" x) (car x)) 767 (Assert (eq (assoc "1" x) (car x)))
767 (Assert-eq (assq "1" x) nil) 768 (Assert (eq (assq "1" x) nil))
768 (Assert-eq (rassoc "1" x) nil) 769 (Assert (eq (rassoc "1" x) nil))
769 (Assert-eq (rassq "1" x) nil) 770 (Assert (eq (rassq "1" x) nil))
770 (Assert-eq (assoc "2" x) nil) 771 (Assert (eq (assoc "2" x) nil))
771 (Assert-eq (assq "2" x) nil) 772 (Assert (eq (assq "2" x) nil))
772 (Assert-eq (rassoc "2" x) (car x)) 773 (Assert (eq (rassoc "2" x) (car x)))
773 (Assert-eq (rassq "2" x) nil) 774 (Assert (eq (rassq "2" x) nil))
774 (Assert-eq (assoc "3" x) nil) 775 (Assert (eq (assoc "3" x) nil))
775 (Assert-eq (assq "3" x) nil) 776 (Assert (eq (assq "3" x) nil))
776 (Assert-eq (rassoc "3" x) nil) 777 (Assert (eq (rassoc "3" x) nil))
777 (Assert-eq (rassq "3" x) nil) 778 (Assert (eq (rassq "3" x) nil))
778 (Assert-eq (assoc "4" x) (caddr x)) 779 (Assert (eq (assoc "4" x) (caddr x)))
779 (Assert-eq (assq "4" x) nil) 780 (Assert (eq (assq "4" x) nil))
780 (Assert-eq (rassoc "4" x) nil) 781 (Assert (eq (rassoc "4" x) nil))
781 (Assert-eq (rassq "4" x) nil) 782 (Assert (eq (rassq "4" x) nil))
782 (Assert-eq (assoc "5" x) nil) 783 (Assert (eq (assoc "5" x) nil))
783 (Assert-eq (assq "5" x) nil) 784 (Assert (eq (assq "5" x) nil))
784 (Assert-eq (rassoc "5" x) (caddr x)) 785 (Assert (eq (rassoc "5" x) (caddr x)))
785 (Assert-eq (rassq "5" x) nil) 786 (Assert (eq (rassq "5" x) nil))
786 (Assert-eq (assoc "6" x) nil) 787 (Assert (eq (assoc "6" x) nil))
787 (Assert-eq (assq "6" x) nil) 788 (Assert (eq (assq "6" x) nil))
788 (Assert-eq (rassoc "6" x) nil) 789 (Assert (eq (rassoc "6" x) nil))
789 (Assert-eq (rassq "6" x) nil)) 790 (Assert (eq (rassq "6" x) nil)))
790 791
791 (flet ((a () (list '(1 . 2) 3 '(4 . 5)))) 792 (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)))))) 793 (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)))))) 794 (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))))) 795 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a)))))
866 ;;----------------------------------------------------- 867 ;;-----------------------------------------------------
867 ;; function-max-args, function-min-args 868 ;; function-max-args, function-min-args
868 ;;----------------------------------------------------- 869 ;;-----------------------------------------------------
869 (defmacro check-function-argcounts (fun min max) 870 (defmacro check-function-argcounts (fun min max)
870 `(progn 871 `(progn
871 (Assert-eq (function-min-args ,fun) ,min) 872 (Assert (eq (function-min-args ,fun) ,min))
872 (Assert-eq (function-max-args ,fun) ,max))) 873 (Assert (eq (function-max-args ,fun) ,max))))
873 874
874 (check-function-argcounts 'prog1 1 nil) ; special form 875 (check-function-argcounts 'prog1 1 nil) ; special form
875 (check-function-argcounts 'command-execute 1 3) ; normal subr 876 (check-function-argcounts 'command-execute 1 3) ; normal subr
876 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr 877 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr
877 (check-function-argcounts 'garbage-collect 0 0) ; no args subr 878 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
894 '((let (1 . unevalled)) 895 '((let (1 . unevalled))
895 (prog1 (1 . unevalled)) 896 (prog1 (1 . unevalled))
896 (list (0 . many)) 897 (list (0 . many))
897 (type-of (1 . 1)) 898 (type-of (1 . 1))
898 (garbage-collect (0 . 0))) 899 (garbage-collect (0 . 0)))
899 do (Assert-equal (subr-arity (symbol-function function-name)) arity)) 900 do (Assert (equal (subr-arity (symbol-function function-name)) arity)))
900 901
901 (Check-Error wrong-type-argument (subr-arity 902 (Check-Error wrong-type-argument (subr-arity
902 (lambda () (message "Hi there!")))) 903 (lambda () (message "Hi there!"))))
903 904
904 (Check-Error wrong-type-argument (subr-arity nil)) 905 (Check-Error wrong-type-argument (subr-arity nil))
916 (fmakunbound 'test-sym2) 917 (fmakunbound 'test-sym2)
917 918
918 ;;----------------------------------------------------- 919 ;;-----------------------------------------------------
919 ;; Test `type-of' 920 ;; Test `type-of'
920 ;;----------------------------------------------------- 921 ;;-----------------------------------------------------
921 (Assert-eq (type-of load-path) 'cons) 922 (Assert (eq (type-of load-path) 'cons))
922 (Assert-eq (type-of obarray) 'vector) 923 (Assert (eq (type-of obarray) 'vector))
923 (Assert-eq (type-of 42) 'integer) 924 (Assert (eq (type-of 42) 'integer))
924 (Assert-eq (type-of ?z) 'character) 925 (Assert (eq (type-of ?z) 'character))
925 (Assert-eq (type-of "42") 'string) 926 (Assert (eq (type-of "42") 'string))
926 (Assert-eq (type-of 'foo) 'symbol) 927 (Assert (eq (type-of 'foo) 'symbol))
927 (Assert-eq (type-of (selected-device)) 'device) 928 (Assert (eq (type-of (selected-device)) 'device))
928 929
929 ;;----------------------------------------------------- 930 ;;-----------------------------------------------------
930 ;; Test mapping functions 931 ;; Test mapping functions
931 ;;----------------------------------------------------- 932 ;;-----------------------------------------------------
932 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer))) 933 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer)))
933 (Assert-equal (mapcar #'identity load-path) load-path) 934 (Assert (equal (mapcar #'identity load-path) load-path))
934 (Assert-equal (mapcar #'identity '(1 2 3)) '(1 2 3)) 935 (Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3)))
935 (Assert-equal (mapcar #'identity "123") '(?1 ?2 ?3)) 936 (Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3)))
936 (Assert-equal (mapcar #'identity [1 2 3]) '(1 2 3)) 937 (Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3)))
937 (Assert-equal (mapcar #'identity #*010) '(0 1 0)) 938 (Assert (equal (mapcar #'identity #*010) '(0 1 0)))
938 939
939 (let ((z 0) (list (make-list 1000 1))) 940 (let ((z 0) (list (make-list 1000 1)))
940 (mapc (lambda (x) (incf z x)) list) 941 (mapc (lambda (x) (incf z x)) list)
941 (Assert-eq 1000 z)) 942 (Assert (eq 1000 z)))
942 943
943 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer))) 944 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer)))
944 (Assert-equal (mapvector #'identity '(1 2 3)) [1 2 3]) 945 (Assert (equal (mapvector #'identity '(1 2 3)) [1 2 3]))
945 (Assert-equal (mapvector #'identity "123") [?1 ?2 ?3]) 946 (Assert (equal (mapvector #'identity "123") [?1 ?2 ?3]))
946 (Assert-equal (mapvector #'identity [1 2 3]) [1 2 3]) 947 (Assert (equal (mapvector #'identity [1 2 3]) [1 2 3]))
947 (Assert-equal (mapvector #'identity #*010) [0 1 0]) 948 (Assert (equal (mapvector #'identity #*010) [0 1 0]))
948 949
949 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo")) 950 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo"))
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 (Assert (equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3"))
952 953
953 ;; The following 2 functions used to crash XEmacs via mapcar1(). 954 ;; 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. 955 ;; We don't test the actual values of the mapcar, since they're undefined.
955 (Assert 956 (Assert
956 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) 957 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
971 (when (eq (car y) 1) 972 (when (eq (car y) 1)
972 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway 973 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway
973 (car y)) 974 (car y))
974 x))) 975 x)))
975 976
976 (Assert-eql 977 (Assert (eql
977 (length (multiple-value-list 978 (length (multiple-value-list
978 (car (mapcar #'(lambda (argument) (floor argument)) (list pi e))))) 979 (car (mapcar #'(lambda (argument) (floor argument)) (list pi e)))))
979 1 980 1)
980 "checking multiple values are correctly discarded in mapcar") 981 "checking multiple values are correctly discarded in mapcar")
981 982
982 ;;----------------------------------------------------- 983 ;;-----------------------------------------------------
983 ;; Test vector functions 984 ;; Test vector functions
984 ;;----------------------------------------------------- 985 ;;-----------------------------------------------------
985 (Assert-equal [1 2 3] [1 2 3]) 986 (Assert (equal [1 2 3] [1 2 3]))
986 (Assert-equal [] []) 987 (Assert (equal [] []))
987 (Assert (not (equal [1 2 3] []))) 988 (Assert (not (equal [1 2 3] [])))
988 (Assert (not (equal [1 2 3] [1 2 4]))) 989 (Assert (not (equal [1 2 3] [1 2 4])))
989 (Assert (not (equal [0 2 3] [1 2 3]))) 990 (Assert (not (equal [0 2 3] [1 2 3])))
990 (Assert (not (equal [1 2 3] [1 2 3 4]))) 991 (Assert (not (equal [1 2 3] [1 2 3 4])))
991 (Assert (not (equal [1 2 3 4] [1 2 3]))) 992 (Assert (not (equal [1 2 3 4] [1 2 3])))
992 (Assert-equal (vector 1 2 3) [1 2 3]) 993 (Assert (equal (vector 1 2 3) [1 2 3]))
993 (Assert-equal (make-vector 3 1) [1 1 1]) 994 (Assert (equal (make-vector 3 1) [1 1 1]))
994 995
995 ;;----------------------------------------------------- 996 ;;-----------------------------------------------------
996 ;; Test bit-vector functions 997 ;; Test bit-vector functions
997 ;;----------------------------------------------------- 998 ;;-----------------------------------------------------
998 (Assert-equal #*010 #*010) 999 (Assert (equal #*010 #*010))
999 (Assert-equal #* #*) 1000 (Assert (equal #* #*))
1000 (Assert (not (equal #*010 #*011))) 1001 (Assert (not (equal #*010 #*011)))
1001 (Assert (not (equal #*010 #*))) 1002 (Assert (not (equal #*010 #*)))
1002 (Assert (not (equal #*110 #*010))) 1003 (Assert (not (equal #*110 #*010)))
1003 (Assert (not (equal #*010 #*0100))) 1004 (Assert (not (equal #*010 #*0100)))
1004 (Assert (not (equal #*0101 #*010))) 1005 (Assert (not (equal #*0101 #*010)))
1005 (Assert-equal (bit-vector 0 1 0) #*010) 1006 (Assert (equal (bit-vector 0 1 0) #*010))
1006 (Assert-equal (make-bit-vector 3 1) #*111) 1007 (Assert (equal (make-bit-vector 3 1) #*111))
1007 (Assert-equal (make-bit-vector 3 0) #*000) 1008 (Assert (equal (make-bit-vector 3 0) #*000))
1008 1009
1009 ;;----------------------------------------------------- 1010 ;;-----------------------------------------------------
1010 ;; Test buffer-local variables used as (ugh!) function parameters 1011 ;; Test buffer-local variables used as (ugh!) function parameters
1011 ;;----------------------------------------------------- 1012 ;;-----------------------------------------------------
1012 (make-local-variable 'test-emacs-buffer-local-variable) 1013 (make-local-variable 'test-emacs-buffer-local-variable)
1020 ;;----------------------------------------------------- 1021 ;;-----------------------------------------------------
1021 ;; Keep nulls, explicit SEPARATORS 1022 ;; Keep nulls, explicit SEPARATORS
1022 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb 1023 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb
1023 ;; I assume Hrvoje worried about the possibility of infloops. -sjt 1024 ;; I assume Hrvoje worried about the possibility of infloops. -sjt
1024 (when test-harness-risk-infloops 1025 (when test-harness-risk-infloops
1025 (Assert-equal (split-string "foo" "") '("" "f" "o" "o" "")) 1026 (Assert (equal (split-string "foo" "") '("" "f" "o" "o" "")))
1026 (Assert-equal (split-string "foo" "^") '("" "foo")) 1027 (Assert (equal (split-string "foo" "^") '("" "foo")))
1027 (Assert-equal (split-string "foo" "$") '("foo" ""))) 1028 (Assert (equal (split-string "foo" "$") '("foo" ""))))
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 (Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,")))
1031 (Assert-equal (split-string ",foo,bar," ",$") '(",foo,bar" "")) 1032 (Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" "")))
1032 (Assert-equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" "")) 1033 (Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" "")))
1033 (Assert-equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar")) 1034 (Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar")))
1034 (Assert-equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" "")) 1035 (Assert (equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" "")))
1035 (Assert-equal (split-string "foo,,bar" ",+") '("foo" "bar")) 1036 (Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar")))
1036 (Assert-equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")) 1037 (Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")))
1037 ;; Omit nulls, explicit SEPARATORS 1038 ;; Omit nulls, explicit SEPARATORS
1038 (when test-harness-risk-infloops 1039 (when test-harness-risk-infloops
1039 (Assert-equal (split-string "foo" "" t) '("f" "o" "o")) 1040 (Assert (equal (split-string "foo" "" t) '("f" "o" "o")))
1040 (Assert-equal (split-string "foo" "^" t) '("foo")) 1041 (Assert (equal (split-string "foo" "^" t) '("foo")))
1041 (Assert-equal (split-string "foo" "$" t) '("foo"))) 1042 (Assert (equal (split-string "foo" "$" t) '("foo"))))
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 (Assert (equal (split-string ",foo,bar," "^," t) '("foo,bar,")))
1045 (Assert-equal (split-string ",foo,bar," ",$" t) '(",foo,bar")) 1046 (Assert (equal (split-string ",foo,bar," ",$" t) '(",foo,bar")))
1046 (Assert-equal (split-string ",foo,,bar," "," t) '("foo" "bar")) 1047 (Assert (equal (split-string ",foo,,bar," "," t) '("foo" "bar")))
1047 (Assert-equal (split-string "foo,,,bar" "," t) '("foo" "bar")) 1048 (Assert (equal (split-string "foo,,,bar" "," t) '("foo" "bar")))
1048 (Assert-equal (split-string "foo,,bar,," "," t) '("foo" "bar")) 1049 (Assert (equal (split-string "foo,,bar,," "," t) '("foo" "bar")))
1049 (Assert-equal (split-string "foo,,bar" ",+" t) '("foo" "bar")) 1050 (Assert (equal (split-string "foo,,bar" ",+" t) '("foo" "bar")))
1050 (Assert-equal (split-string ",foo,,bar," ",+" t) '("foo" "bar")) 1051 (Assert (equal (split-string ",foo,,bar," ",+" t) '("foo" "bar")))
1051 ;; "Double-default" case 1052 ;; "Double-default" case
1052 (Assert-equal (split-string "foo bar") '("foo" "bar")) 1053 (Assert (equal (split-string "foo bar") '("foo" "bar")))
1053 (Assert-equal (split-string " foo bar ") '("foo" "bar")) 1054 (Assert (equal (split-string " foo bar ") '("foo" "bar")))
1054 (Assert-equal (split-string " foo bar ") '("foo" "bar")) 1055 (Assert (equal (split-string " foo bar ") '("foo" "bar")))
1055 (Assert-equal (split-string "foo bar") '("foo" "bar")) 1056 (Assert (equal (split-string "foo bar") '("foo" "bar")))
1056 (Assert-equal (split-string "foo bar ") '("foo" "bar")) 1057 (Assert (equal (split-string "foo bar ") '("foo" "bar")))
1057 (Assert-equal (split-string "foobar") '("foobar")) 1058 (Assert (equal (split-string "foobar") '("foobar")))
1058 ;; Semantics are identical to "double-default" case! Fool ya? 1059 ;; Semantics are identical to "double-default" case! Fool ya?
1059 (Assert-equal (split-string "foo bar" nil t) '("foo" "bar")) 1060 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar")))
1060 (Assert-equal (split-string " foo bar " nil t) '("foo" "bar")) 1061 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar")))
1061 (Assert-equal (split-string " foo bar " nil t) '("foo" "bar")) 1062 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar")))
1062 (Assert-equal (split-string "foo bar" nil t) '("foo" "bar")) 1063 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar")))
1063 (Assert-equal (split-string "foo bar " nil t) '("foo" "bar")) 1064 (Assert (equal (split-string "foo bar " nil t) '("foo" "bar")))
1064 (Assert-equal (split-string "foobar" nil t) '("foobar")) 1065 (Assert (equal (split-string "foobar" nil t) '("foobar")))
1065 ;; Perverse "anti-double-default" case 1066 ;; Perverse "anti-double-default" case
1066 (Assert-equal (split-string "foo bar" split-string-default-separators) 1067 (Assert (equal (split-string "foo bar" split-string-default-separators)
1067 '("foo" "bar")) 1068 '("foo" "bar")))
1068 (Assert-equal (split-string " foo bar " split-string-default-separators) 1069 (Assert (equal (split-string " foo bar " split-string-default-separators)
1069 '("" "foo" "bar" "")) 1070 '("" "foo" "bar" "")))
1070 (Assert-equal (split-string " foo bar " split-string-default-separators) 1071 (Assert (equal (split-string " foo bar " split-string-default-separators)
1071 '("" "foo" "bar" "")) 1072 '("" "foo" "bar" "")))
1072 (Assert-equal (split-string "foo bar" split-string-default-separators) 1073 (Assert (equal (split-string "foo bar" split-string-default-separators)
1073 '("foo" "bar")) 1074 '("foo" "bar")))
1074 (Assert-equal (split-string "foo bar " split-string-default-separators) 1075 (Assert (equal (split-string "foo bar " split-string-default-separators)
1075 '("foo" "bar" "")) 1076 '("foo" "bar" "")))
1076 (Assert-equal (split-string "foobar" split-string-default-separators) 1077 (Assert (equal (split-string "foobar" split-string-default-separators)
1077 '("foobar")) 1078 '("foobar")))
1078 1079
1079 ;;----------------------------------------------------- 1080 ;;-----------------------------------------------------
1080 ;; Test split-string-by-char 1081 ;; Test split-string-by-char
1081 ;;----------------------------------------------------- 1082 ;;-----------------------------------------------------
1082 1083
1149 ;;----------------------------------------------------- 1150 ;;-----------------------------------------------------
1150 ;; Test near-text buffer functions. 1151 ;; Test near-text buffer functions.
1151 ;;----------------------------------------------------- 1152 ;;-----------------------------------------------------
1152 (with-temp-buffer 1153 (with-temp-buffer
1153 (erase-buffer) 1154 (erase-buffer)
1154 (Assert-eq (char-before) nil) 1155 (Assert (eq (char-before) nil))
1155 (Assert-eq (char-before (point)) nil) 1156 (Assert (eq (char-before (point)) nil))
1156 (Assert-eq (char-before (point-marker)) nil) 1157 (Assert (eq (char-before (point-marker)) nil))
1157 (Assert-eq (char-before (point) (current-buffer)) nil) 1158 (Assert (eq (char-before (point) (current-buffer)) nil))
1158 (Assert-eq (char-before (point-marker) (current-buffer)) nil) 1159 (Assert (eq (char-before (point-marker) (current-buffer)) nil))
1159 (Assert-eq (char-after) nil) 1160 (Assert (eq (char-after) nil))
1160 (Assert-eq (char-after (point)) nil) 1161 (Assert (eq (char-after (point)) nil))
1161 (Assert-eq (char-after (point-marker)) nil) 1162 (Assert (eq (char-after (point-marker)) nil))
1162 (Assert-eq (char-after (point) (current-buffer)) nil) 1163 (Assert (eq (char-after (point) (current-buffer)) nil))
1163 (Assert-eq (char-after (point-marker) (current-buffer)) nil) 1164 (Assert (eq (char-after (point-marker) (current-buffer)) nil))
1164 (Assert-eq (preceding-char) 0) 1165 (Assert (eq (preceding-char) 0))
1165 (Assert-eq (preceding-char (current-buffer)) 0) 1166 (Assert (eq (preceding-char (current-buffer)) 0))
1166 (Assert-eq (following-char) 0) 1167 (Assert (eq (following-char) 0))
1167 (Assert-eq (following-char (current-buffer)) 0) 1168 (Assert (eq (following-char (current-buffer)) 0))
1168 (insert "foobar") 1169 (insert "foobar")
1169 (Assert-eq (char-before) ?r) 1170 (Assert (eq (char-before) ?r))
1170 (Assert-eq (char-after) nil) 1171 (Assert (eq (char-after) nil))
1171 (Assert-eq (preceding-char) ?r) 1172 (Assert (eq (preceding-char) ?r))
1172 (Assert-eq (following-char) 0) 1173 (Assert (eq (following-char) 0))
1173 (goto-char (point-min)) 1174 (goto-char (point-min))
1174 (Assert-eq (char-before) nil) 1175 (Assert (eq (char-before) nil))
1175 (Assert-eq (char-after) ?f) 1176 (Assert (eq (char-after) ?f))
1176 (Assert-eq (preceding-char) 0) 1177 (Assert (eq (preceding-char) 0))
1177 (Assert-eq (following-char) ?f) 1178 (Assert (eq (following-char) ?f))
1178 ) 1179 )
1179 1180
1180 ;;----------------------------------------------------- 1181 ;;-----------------------------------------------------
1181 ;; Test plist manipulation functions. 1182 ;; Test plist manipulation functions.
1182 ;;----------------------------------------------------- 1183 ;;-----------------------------------------------------
1183 (let ((sym (make-symbol "test-symbol"))) 1184 (let ((sym (make-symbol "test-symbol")))
1184 (Assert-eq t (get* sym t t)) 1185 (Assert (eq t (get* sym t t)))
1185 (Assert-eq t (get sym t t)) 1186 (Assert (eq t (get sym t t)))
1186 (Assert-eq t (getf nil t t)) 1187 (Assert (eq t (getf nil t t)))
1187 (Assert-eq t (plist-get nil t t)) 1188 (Assert (eq t (plist-get nil t t)))
1188 (put sym 'bar 'baz) 1189 (put sym 'bar 'baz)
1189 (Assert-eq 'baz (get sym 'bar)) 1190 (Assert (eq 'baz (get sym 'bar)))
1190 (Assert-eq 'baz (getf '(bar baz) 'bar)) 1191 (Assert (eq 'baz (getf '(bar baz) 'bar)))
1191 (Assert-eq 'baz (getf (symbol-plist sym) 'bar)) 1192 (Assert (eq 'baz (getf (symbol-plist sym) 'bar)))
1192 (Assert-eq 2 (getf '(1 2) 1)) 1193 (Assert (eq 2 (getf '(1 2) 1)))
1193 (Assert-eq 4 (put sym 3 4)) 1194 (Assert (eq 4 (put sym 3 4)))
1194 (Assert-eq 4 (get sym 3)) 1195 (Assert (eq 4 (get sym 3)))
1195 (Assert-eq t (remprop sym 3)) 1196 (Assert (eq t (remprop sym 3)))
1196 (Assert-eq nil (remprop sym 3)) 1197 (Assert (eq nil (remprop sym 3)))
1197 (Assert-eq 5 (get sym 3 5)) 1198 (Assert (eq 5 (get sym 3 5)))
1198 ) 1199 )
1199 1200
1200 (loop for obj in 1201 (loop for obj in
1201 (list (make-symbol "test-symbol") 1202 (list (make-symbol "test-symbol")
1202 "test-string" 1203 "test-string"
1203 (make-extent nil nil nil) 1204 (make-extent nil nil nil)
1204 (make-face 'test-face)) 1205 (make-face 'test-face))
1205 do 1206 do
1206 (Assert-eq 2 (get obj ?1 2) obj) 1207 (Assert (eq 2 (get obj ?1 2)) obj)
1207 (Assert-eq 4 (put obj ?3 4) obj) 1208 (Assert (eq 4 (put obj ?3 4)) obj)
1208 (Assert-eq 4 (get obj ?3) obj) 1209 (Assert (eq 4 (get obj ?3)) obj)
1209 (when (or (stringp obj) (symbolp obj)) 1210 (when (or (stringp obj) (symbolp obj))
1210 (Assert-equal '(?3 4) (object-plist obj) obj)) 1211 (Assert (equal '(?3 4) (object-plist obj)) obj))
1211 (Assert-eq t (remprop obj ?3) obj) 1212 (Assert (eq t (remprop obj ?3)) obj)
1212 (when (or (stringp obj) (symbolp obj)) 1213 (when (or (stringp obj) (symbolp obj))
1213 (Assert-eq '() (object-plist obj) obj)) 1214 (Assert (eq '() (object-plist obj)) obj))
1214 (Assert-eq nil (remprop obj ?3) obj) 1215 (Assert (eq nil (remprop obj ?3)) obj)
1215 (when (or (stringp obj) (symbolp obj)) 1216 (when (or (stringp obj) (symbolp obj))
1216 (Assert-eq '() (object-plist obj) obj)) 1217 (Assert (eq '() (object-plist obj)) obj))
1217 (Assert-eq 5 (get obj ?3 5) obj) 1218 (Assert (eq 5 (get obj ?3 5)) obj)
1218 ) 1219 )
1219 1220
1220 (Check-Error-Message 1221 (Check-Error-Message
1221 error "Object type has no properties" 1222 error "Object type has no properties"
1222 (get 2 'property)) 1223 (get 2 'property))
1238 (remprop (make-extent nil nil nil) 'detachable)) 1239 (remprop (make-extent nil nil nil) 'detachable))
1239 1240
1240 ;;----------------------------------------------------- 1241 ;;-----------------------------------------------------
1241 ;; Test subseq 1242 ;; Test subseq
1242 ;;----------------------------------------------------- 1243 ;;-----------------------------------------------------
1243 (Assert-equal (subseq nil 0) nil) 1244 (Assert (equal (subseq nil 0) nil))
1244 (Assert-equal (subseq [1 2 3] 0) [1 2 3]) 1245 (Assert (equal (subseq [1 2 3] 0) [1 2 3]))
1245 (Assert-equal (subseq [1 2 3] 1 -1) [2]) 1246 (Assert (equal (subseq [1 2 3] 1 -1) [2]))
1246 (Assert-equal (subseq "123" 0) "123") 1247 (Assert (equal (subseq "123" 0) "123"))
1247 (Assert-equal (subseq "1234" -3 -1) "23") 1248 (Assert (equal (subseq "1234" -3 -1) "23"))
1248 (Assert-equal (subseq #*0011 0) #*0011) 1249 (Assert (equal (subseq #*0011 0) #*0011))
1249 (Assert-equal (subseq #*0011 -3 3) #*01) 1250 (Assert (equal (subseq #*0011 -3 3) #*01))
1250 (Assert-equal (subseq '(1 2 3) 0) '(1 2 3)) 1251 (Assert (equal (subseq '(1 2 3) 0) '(1 2 3)))
1251 (Assert-equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)) 1252 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)))
1252 1253
1253 (Check-Error wrong-type-argument (subseq 3 2)) 1254 (Check-Error wrong-type-argument (subseq 3 2))
1254 (Check-Error args-out-of-range (subseq [1 2 3] -42)) 1255 (Check-Error args-out-of-range (subseq [1 2 3] -42))
1255 (Check-Error args-out-of-range (subseq [1 2 3] 0 42)) 1256 (Check-Error args-out-of-range (subseq [1 2 3] 0 42))
1256 1257
1257 ;;----------------------------------------------------- 1258 ;;-----------------------------------------------------
1258 ;; Time-related tests 1259 ;; Time-related tests
1259 ;;----------------------------------------------------- 1260 ;;-----------------------------------------------------
1260 (Assert= (length (current-time-string)) 24) 1261 (Assert (= (length (current-time-string)) 24))
1261 1262
1262 ;;----------------------------------------------------- 1263 ;;-----------------------------------------------------
1263 ;; format test 1264 ;; format test
1264 ;;----------------------------------------------------- 1265 ;;-----------------------------------------------------
1265 (Assert (string= (format "%d" 10) "10")) 1266 (Assert (string= (format "%d" 10) "10"))
1345 (Assert (string= (format "%1.3d" 10) "010")) 1346 (Assert (string= (format "%1.3d" 10) "010"))
1346 (Assert (string= (format "%3.1d" 10) " 10")) 1347 (Assert (string= (format "%3.1d" 10) " 10"))
1347 1348
1348 ;;; The following two tests used to use 1000 instead of 100, 1349 ;;; The following two tests used to use 1000 instead of 100,
1349 ;;; but that merely found buffer overflow bugs in Solaris sprintf(). 1350 ;;; but that merely found buffer overflow bugs in Solaris sprintf().
1350 (Assert= 102 (length (format "%.100f" 3.14))) 1351 (Assert (= 102 (length (format "%.100f" 3.14))))
1351 (Assert= 100 (length (format "%100f" 3.14))) 1352 (Assert (= 100 (length (format "%100f" 3.14))))
1352 1353
1353 ;;; Check for 64-bit cleanness on LP64 platforms. 1354 ;;; Check for 64-bit cleanness on LP64 platforms.
1354 (Assert= (read (format "%d" most-positive-fixnum)) most-positive-fixnum) 1355 (Assert (= (read (format "%d" most-positive-fixnum)) most-positive-fixnum))
1355 (Assert= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum) 1356 (Assert (= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum))
1356 (Assert= (read (format "%u" most-positive-fixnum)) most-positive-fixnum) 1357 (Assert (= (read (format "%u" most-positive-fixnum)) most-positive-fixnum))
1357 (Assert= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum) 1358 (Assert (= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum))
1358 (Assert= (read (format "%d" most-negative-fixnum)) most-negative-fixnum) 1359 (Assert (= (read (format "%d" most-negative-fixnum)) most-negative-fixnum))
1359 (Assert= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum) 1360 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum))
1360 1361
1361 ;; These used to crash. 1362 ;; These used to crash.
1362 (Assert-eql (read (format "%f" 1.2e+302)) 1.2e+302) 1363 (Assert (eql (read (format "%f" 1.2e+302)) 1.2e+302))
1363 (Assert-eql (read (format "%.1000d" 1)) 1) 1364 (Assert (eql (read (format "%.1000d" 1)) 1))
1364 1365
1365 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. 1366 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type.
1366 ;;; What to do if "%u" is used with a negative number? 1367 ;;; What to do if "%u" is used with a negative number?
1367 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an 1368 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an
1368 ;;; un-read-able number. The printed value might be useful to a human, if not 1369 ;;; un-read-able number. The printed value might be useful to a human, if not
1416 old-char) 1417 old-char)
1417 (setq old-char (aref load-file-name 0)) 1418 (setq old-char (aref load-file-name 0))
1418 (if (= new-char old-char) 1419 (if (= new-char old-char)
1419 (setq new-char ?/)) 1420 (setq new-char ?/))
1420 (aset load-file-name 0 new-char) 1421 (aset load-file-name 0 new-char)
1421 (Assert= new-char (aref load-file-name 0) 1422 (Assert (= new-char (aref load-file-name 0))
1422 \"Check that we can modify the string value of load-file-name\")) 1423 \"Check that we can modify the string value of load-file-name\"))
1423 1424
1424 (let* ((new-load-file-name \"hi there\") 1425 (let* ((new-load-file-name \"hi there\")
1425 (load-file-name new-load-file-name)) 1426 (load-file-name new-load-file-name))
1426 (Assert-eq new-load-file-name load-file-name 1427 (Assert (eq new-load-file-name load-file-name)
1427 \"Checking that we can bind load-file-name successfully.\")) 1428 \"Checking that we can bind load-file-name successfully.\"))
1428 1429
1429 ") 1430 ")
1430 (write-region (point-min) (point-max) test-file-name nil 'quiet) 1431 (write-region (point-min) (point-max) test-file-name nil 'quiet)
1431 (set-buffer-modified-p nil) 1432 (set-buffer-modified-p nil)
1465 one-fceiling-result two-fceiling-result 1466 one-fceiling-result two-fceiling-result
1466 one-round-result two-round-result 1467 one-round-result two-round-result
1467 one-fround-result two-fround-result 1468 one-fround-result two-fround-result
1468 one-truncate-result two-truncate-result 1469 one-truncate-result two-truncate-result
1469 one-ftruncate-result two-ftruncate-result) 1470 one-ftruncate-result two-ftruncate-result)
1470 (Assert-equal one-floor-result (multiple-value-list 1471 (Assert (equal one-floor-result (multiple-value-list
1471 (floor first)) 1472 (floor first)))
1472 (format "checking (floor %S) gives %S" 1473 (format "checking (floor %S) gives %S"
1473 first one-floor-result)) 1474 first one-floor-result))
1474 (Assert-equal one-floor-result (multiple-value-list 1475 (Assert (equal one-floor-result (multiple-value-list
1475 (floor first 1)) 1476 (floor first 1)))
1476 (format "checking (floor %S 1) gives %S" 1477 (format "checking (floor %S 1) gives %S"
1477 first one-floor-result)) 1478 first one-floor-result))
1478 (Check-Error arith-error (floor first 0)) 1479 (Check-Error arith-error (floor first 0))
1479 (Check-Error arith-error (floor first 0.0)) 1480 (Check-Error arith-error (floor first 0.0))
1480 (Assert-equal two-floor-result (multiple-value-list 1481 (Assert (equal two-floor-result (multiple-value-list
1481 (floor first second)) 1482 (floor first second)))
1482 (format 1483 (format
1483 "checking (floor %S %S) gives %S" 1484 "checking (floor %S %S) gives %S"
1484 first second two-floor-result)) 1485 first second two-floor-result))
1485 (Assert-equal (cl-floor first second) 1486 (Assert (equal (cl-floor first second)
1486 (multiple-value-list (floor first second)) 1487 (multiple-value-list (floor first second)))
1487 (format 1488 (format
1488 "checking (floor %S %S) gives the same as the old code" 1489 "checking (floor %S %S) gives the same as the old code"
1489 first second)) 1490 first second))
1490 (Assert-equal one-ffloor-result (multiple-value-list 1491 (Assert (equal one-ffloor-result (multiple-value-list
1491 (ffloor first)) 1492 (ffloor first)))
1492 (format "checking (ffloor %S) gives %S" 1493 (format "checking (ffloor %S) gives %S"
1493 first one-ffloor-result)) 1494 first one-ffloor-result))
1494 (Assert-equal one-ffloor-result (multiple-value-list 1495 (Assert (equal one-ffloor-result (multiple-value-list
1495 (ffloor first 1)) 1496 (ffloor first 1)))
1496 (format "checking (ffloor %S 1) gives %S" 1497 (format "checking (ffloor %S 1) gives %S"
1497 first one-ffloor-result)) 1498 first one-ffloor-result))
1498 (Check-Error arith-error (ffloor first 0)) 1499 (Check-Error arith-error (ffloor first 0))
1499 (Check-Error arith-error (ffloor first 0.0)) 1500 (Check-Error arith-error (ffloor first 0.0))
1500 (Assert-equal two-ffloor-result (multiple-value-list 1501 (Assert (equal two-ffloor-result (multiple-value-list
1501 (ffloor first second)) 1502 (ffloor first second)))
1502 (format "checking (ffloor %S %S) gives %S" 1503 (format "checking (ffloor %S %S) gives %S"
1503 first second two-ffloor-result)) 1504 first second two-ffloor-result))
1504 (Assert-equal one-ceiling-result (multiple-value-list 1505 (Assert (equal one-ceiling-result (multiple-value-list
1505 (ceiling first)) 1506 (ceiling first)))
1506 (format "checking (ceiling %S) gives %S" 1507 (format "checking (ceiling %S) gives %S"
1507 first one-ceiling-result)) 1508 first one-ceiling-result))
1508 (Assert-equal one-ceiling-result (multiple-value-list 1509 (Assert (equal one-ceiling-result (multiple-value-list
1509 (ceiling first 1)) 1510 (ceiling first 1)))
1510 (format "checking (ceiling %S 1) gives %S" 1511 (format "checking (ceiling %S 1) gives %S"
1511 first one-ceiling-result)) 1512 first one-ceiling-result))
1512 (Check-Error arith-error (ceiling first 0)) 1513 (Check-Error arith-error (ceiling first 0))
1513 (Check-Error arith-error (ceiling first 0.0)) 1514 (Check-Error arith-error (ceiling first 0.0))
1514 (Assert-equal two-ceiling-result (multiple-value-list 1515 (Assert (equal two-ceiling-result (multiple-value-list
1515 (ceiling first second)) 1516 (ceiling first second)))
1516 (format "checking (ceiling %S %S) gives %S" 1517 (format "checking (ceiling %S %S) gives %S"
1517 first second two-ceiling-result)) 1518 first second two-ceiling-result))
1518 (Assert-equal (cl-ceiling first second) 1519 (Assert (equal (cl-ceiling first second)
1519 (multiple-value-list (ceiling first second)) 1520 (multiple-value-list (ceiling first second)))
1520 (format 1521 (format
1521 "checking (ceiling %S %S) gives the same as the old code" 1522 "checking (ceiling %S %S) gives the same as the old code"
1522 first second)) 1523 first second))
1523 (Assert-equal one-fceiling-result (multiple-value-list 1524 (Assert (equal one-fceiling-result (multiple-value-list
1524 (fceiling first)) 1525 (fceiling first)))
1525 (format "checking (fceiling %S) gives %S" 1526 (format "checking (fceiling %S) gives %S"
1526 first one-fceiling-result)) 1527 first one-fceiling-result))
1527 (Assert-equal one-fceiling-result (multiple-value-list 1528 (Assert (equal one-fceiling-result (multiple-value-list
1528 (fceiling first 1)) 1529 (fceiling first 1)))
1529 (format "checking (fceiling %S 1) gives %S" 1530 (format "checking (fceiling %S 1) gives %S"
1530 first one-fceiling-result)) 1531 first one-fceiling-result))
1531 (Check-Error arith-error (fceiling first 0)) 1532 (Check-Error arith-error (fceiling first 0))
1532 (Check-Error arith-error (fceiling first 0.0)) 1533 (Check-Error arith-error (fceiling first 0.0))
1533 (Assert-equal two-fceiling-result (multiple-value-list 1534 (Assert (equal two-fceiling-result (multiple-value-list
1534 (fceiling first second)) 1535 (fceiling first second)))
1535 (format "checking (fceiling %S %S) gives %S" 1536 (format "checking (fceiling %S %S) gives %S"
1536 first second two-fceiling-result)) 1537 first second two-fceiling-result))
1537 (Assert-equal one-round-result (multiple-value-list 1538 (Assert (equal one-round-result (multiple-value-list
1538 (round first)) 1539 (round first)))
1539 (format "checking (round %S) gives %S" 1540 (format "checking (round %S) gives %S"
1540 first one-round-result)) 1541 first one-round-result))
1541 (Assert-equal one-round-result (multiple-value-list 1542 (Assert (equal one-round-result (multiple-value-list
1542 (round first 1)) 1543 (round first 1)))
1543 (format "checking (round %S 1) gives %S" 1544 (format "checking (round %S 1) gives %S"
1544 first one-round-result)) 1545 first one-round-result))
1545 (Check-Error arith-error (round first 0)) 1546 (Check-Error arith-error (round first 0))
1546 (Check-Error arith-error (round first 0.0)) 1547 (Check-Error arith-error (round first 0.0))
1547 (Assert-equal two-round-result (multiple-value-list 1548 (Assert (equal two-round-result (multiple-value-list
1548 (round first second)) 1549 (round first second)))
1549 (format "checking (round %S %S) gives %S" 1550 (format "checking (round %S %S) gives %S"
1550 first second two-round-result)) 1551 first second two-round-result))
1551 (Assert-equal one-fround-result (multiple-value-list 1552 (Assert (equal one-fround-result (multiple-value-list
1552 (fround first)) 1553 (fround first)))
1553 (format "checking (fround %S) gives %S" 1554 (format "checking (fround %S) gives %S"
1554 first one-fround-result)) 1555 first one-fround-result))
1555 (Assert-equal one-fround-result (multiple-value-list 1556 (Assert (equal one-fround-result (multiple-value-list
1556 (fround first 1)) 1557 (fround first 1)))
1557 (format "checking (fround %S 1) gives %S" 1558 (format "checking (fround %S 1) gives %S"
1558 first one-fround-result)) 1559 first one-fround-result))
1559 (Check-Error arith-error (fround first 0)) 1560 (Check-Error arith-error (fround first 0))
1560 (Check-Error arith-error (fround first 0.0)) 1561 (Check-Error arith-error (fround first 0.0))
1561 (Assert-equal two-fround-result (multiple-value-list 1562 (Assert (equal two-fround-result (multiple-value-list
1562 (fround first second)) 1563 (fround first second)))
1563 (format "checking (fround %S %S) gives %S" 1564 (format "checking (fround %S %S) gives %S"
1564 first second two-fround-result)) 1565 first second two-fround-result))
1565 (Assert-equal (cl-round first second) 1566 (Assert (equal (cl-round first second)
1566 (multiple-value-list (round first second)) 1567 (multiple-value-list (round first second)))
1567 (format 1568 (format
1568 "checking (round %S %S) gives the same as the old code" 1569 "checking (round %S %S) gives the same as the old code"
1569 first second)) 1570 first second))
1570 (Assert-equal one-truncate-result (multiple-value-list 1571 (Assert (equal one-truncate-result (multiple-value-list
1571 (truncate first)) 1572 (truncate first)))
1572 (format "checking (truncate %S) gives %S" 1573 (format "checking (truncate %S) gives %S"
1573 first one-truncate-result)) 1574 first one-truncate-result))
1574 (Assert-equal one-truncate-result (multiple-value-list 1575 (Assert (equal one-truncate-result (multiple-value-list
1575 (truncate first 1)) 1576 (truncate first 1)))
1576 (format "checking (truncate %S 1) gives %S" 1577 (format "checking (truncate %S 1) gives %S"
1577 first one-truncate-result)) 1578 first one-truncate-result))
1578 (Check-Error arith-error (truncate first 0)) 1579 (Check-Error arith-error (truncate first 0))
1579 (Check-Error arith-error (truncate first 0.0)) 1580 (Check-Error arith-error (truncate first 0.0))
1580 (Assert-equal two-truncate-result (multiple-value-list 1581 (Assert (equal two-truncate-result (multiple-value-list
1581 (truncate first second)) 1582 (truncate first second)))
1582 (format "checking (truncate %S %S) gives %S" 1583 (format "checking (truncate %S %S) gives %S"
1583 first second two-truncate-result)) 1584 first second two-truncate-result))
1584 (Assert-equal (cl-truncate first second) 1585 (Assert (equal (cl-truncate first second)
1585 (multiple-value-list (truncate first second)) 1586 (multiple-value-list (truncate first second)))
1586 (format 1587 (format
1587 "checking (truncate %S %S) gives the same as the old code" 1588 "checking (truncate %S %S) gives the same as the old code"
1588 first second)) 1589 first second))
1589 (Assert-equal one-ftruncate-result (multiple-value-list 1590 (Assert (equal one-ftruncate-result (multiple-value-list
1590 (ftruncate first)) 1591 (ftruncate first)))
1591 (format "checking (ftruncate %S) gives %S" 1592 (format "checking (ftruncate %S) gives %S"
1592 first one-ftruncate-result)) 1593 first one-ftruncate-result))
1593 (Assert-equal one-ftruncate-result (multiple-value-list 1594 (Assert (equal one-ftruncate-result (multiple-value-list
1594 (ftruncate first 1)) 1595 (ftruncate first 1)))
1595 (format "checking (ftruncate %S 1) gives %S" 1596 (format "checking (ftruncate %S 1) gives %S"
1596 first one-ftruncate-result)) 1597 first one-ftruncate-result))
1597 (Check-Error arith-error (ftruncate first 0)) 1598 (Check-Error arith-error (ftruncate first 0))
1598 (Check-Error arith-error (ftruncate first 0.0)) 1599 (Check-Error arith-error (ftruncate first 0.0))
1599 (Assert-equal two-ftruncate-result (multiple-value-list 1600 (Assert (equal two-ftruncate-result (multiple-value-list
1600 (ftruncate first second)) 1601 (ftruncate first second)))
1601 (format "checking (ftruncate %S %S) gives %S" 1602 (format "checking (ftruncate %S %S) gives %S"
1602 first second two-ftruncate-result))) 1603 first second two-ftruncate-result)))
1603 (Assert-rounding-floating (pie ee) 1604 (Assert-rounding-floating (pie ee)
1604 (let ((pie-type (type-of pie))) 1605 (let ((pie-type (type-of pie)))
1605 (assert (eq pie-type (type-of ee)) t 1606 (assert (eq pie-type (type-of ee)) t
2031 (Assert 2032 (Assert
2032 (= 1 (length (multiple-value-list 2033 (= 1 (length (multiple-value-list
2033 (foo-zero 400 (1+ most-positive-fixnum))))) 2034 (foo-zero 400 (1+ most-positive-fixnum)))))
2034 "Checking multiple values are discarded correctly when forced") 2035 "Checking multiple values are discarded correctly when forced")
2035 (Check-Error setting-constant (setq multiple-values-limit 20)) 2036 (Check-Error setting-constant (setq multiple-values-limit 20))
2036 (Assert-equal '(-1 1) 2037 (Assert (equal '(-1 1)
2037 (multiple-value-list (floor -3 4)) 2038 (multiple-value-list (floor -3 4)))
2038 "Checking #'multiple-value-list gives a sane result") 2039 "Checking #'multiple-value-list gives a sane result")
2039 (let ((ey 40000) 2040 (let ((ey 40000)
2040 (bee "this is a string") 2041 (bee "this is a string")
2041 (cee #s(hash-table size 256 data (969 ?\xF9)))) 2042 (cee #s(hash-table size 256 data (969 ?\xF9))))
2042 (Assert-equal 2043 (Assert (equal
2043 (multiple-value-list (values ey bee cee)) 2044 (multiple-value-list (values ey bee cee))
2044 (multiple-value-list (values-list (list ey bee cee))) 2045 (multiple-value-list (values-list (list ey bee cee))))
2045 "Checking that #'values and #'values-list are correctly related") 2046 "Checking that #'values and #'values-list are correctly related")
2046 (Assert-equal 2047 (Assert (equal
2047 (multiple-value-list (values-list (list ey bee cee))) 2048 (multiple-value-list (values-list (list ey bee cee)))
2048 (multiple-value-list (apply #'values (list ey bee cee))) 2049 (multiple-value-list (apply #'values (list ey bee cee))))
2049 "Checking #'values-list and #'apply with #values are correctly related")) 2050 "Checking #'values-list and #'apply with #values are correctly related"))
2050 (Assert= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10 2051 (Assert (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10)
2051 "Checking #'multiple-value-call gives reasonable results.") 2052 "Checking #'multiple-value-call gives reasonable results.")
2052 (Assert= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10 2053 (Assert (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10)
2053 "Checking #'multiple-value-call correct when first arg multiple.") 2054 "Checking #'multiple-value-call correct when first arg multiple.")
2054 (Assert= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))) 2055 (Assert (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))))
2055 "Checking #'prog1 does not pass back multiple values") 2056 "Checking #'prog1 does not pass back multiple values")
2056 (Assert= 2 (length (multiple-value-list 2057 (Assert (= 2 (length (multiple-value-list
2057 (multiple-value-prog1 (floor pi) "hi there"))) 2058 (multiple-value-prog1 (floor pi) "hi there"))))
2058 "Checking #'multiple-value-prog1 passes back multiple values") 2059 "Checking #'multiple-value-prog1 passes back multiple values")
2059 (multiple-value-bind (floored remainder this-is-nil) 2060 (multiple-value-bind (floored remainder this-is-nil)
2060 (floor pi 1.0) 2061 (floor pi 1.0)
2061 (Assert= floored 3 2062 (Assert (= floored 3)
2062 "Checking floored bound correctly") 2063 "Checking floored bound correctly")
2063 (Assert-eql remainder (- pi 3.0) 2064 (Assert (eql remainder (- pi 3.0))
2064 "Checking remainder bound correctly") 2065 "Checking remainder bound correctly")
2065 (Assert (null this-is-nil) 2066 (Assert (null this-is-nil)
2066 "Checking trailing arg bound but nil")) 2067 "Checking trailing arg bound but nil"))
2067 (let ((ey 40000) 2068 (let ((ey 40000)
2068 (bee "this is a string") 2069 (bee "this is a string")
2069 (cee #s(hash-table size 256 data (969 ?\xF9)))) 2070 (cee #s(hash-table size 256 data (969 ?\xF9))))
2070 (multiple-value-setq (ey bee cee) 2071 (multiple-value-setq (ey bee cee)
2071 (ffloor e 1.0)) 2072 (ffloor e 1.0))
2072 (Assert-eql 2.0 ey "Checking ey set correctly") 2073 (Assert (eql 2.0 ey) "Checking ey set correctly")
2073 (Assert-eql bee (- e 2.0) "Checking bee set correctly") 2074 (Assert (eql bee (- e 2.0)) "Checking bee set correctly")
2074 (Assert (null cee) "Checking cee set to nil correctly")) 2075 (Assert (null cee) "Checking cee set to nil correctly"))
2075 (Assert= 3 (length (multiple-value-list (eval '(values nil t pi)))) 2076 (Assert (= 3 (length (multiple-value-list (eval '(values nil t pi)))))
2076 "Checking #'eval passes back multiple values") 2077 "Checking #'eval passes back multiple values")
2077 (Assert= 2 (length (multiple-value-list (apply #'floor '(5 3)))) 2078 (Assert (= 2 (length (multiple-value-list (apply #'floor '(5 3)))))
2078 "Checking #'apply passes back multiple values") 2079 "Checking #'apply passes back multiple values")
2079 (Assert= 2 (length (multiple-value-list (funcall #'floor 5 3))) 2080 (Assert (= 2 (length (multiple-value-list (funcall #'floor 5 3))))
2080 "Checking #'funcall passes back multiple values") 2081 "Checking #'funcall passes back multiple values")
2081 (Assert-equal '(1 2) (multiple-value-list 2082 (Assert (equal '(1 2) (multiple-value-list
2082 (multiple-value-call #'floor (values 5 3))) 2083 (multiple-value-call #'floor (values 5 3))))
2083 "Checking #'multiple-value-call passes back multiple values correctly") 2084 "Checking #'multiple-value-call passes back multiple values correctly")
2084 (Assert= 1 (length (multiple-value-list 2085 (Assert (= 1 (length (multiple-value-list
2085 (and (multiple-value-function-returning-nil) t))) 2086 (and (multiple-value-function-returning-nil) t))))
2086 "Checking multiple values from non-trailing forms discarded by #'and") 2087 "Checking multiple values from non-trailing forms discarded by #'and")
2087 (Assert= 5 (length (multiple-value-list 2088 (Assert (= 5 (length (multiple-value-list
2088 (and t (multiple-value-function-returning-nil)))) 2089 (and t (multiple-value-function-returning-nil)))))
2089 "Checking multiple values from final forms not discarded by #'and") 2090 "Checking multiple values from final forms not discarded by #'and")
2090 (Assert= 1 (length (multiple-value-list 2091 (Assert (= 1 (length (multiple-value-list
2091 (or (multiple-value-function-returning-t) t))) 2092 (or (multiple-value-function-returning-t) t))))
2092 "Checking multiple values from non-trailing forms discarded by #'and") 2093 "Checking multiple values from non-trailing forms discarded by #'and")
2093 (Assert= 5 (length (multiple-value-list 2094 (Assert (= 5 (length (multiple-value-list
2094 (or nil (multiple-value-function-returning-t)))) 2095 (or nil (multiple-value-function-returning-t)))))
2095 "Checking multiple values from final forms not discarded by #'and") 2096 "Checking multiple values from final forms not discarded by #'and")
2096 (Assert= 1 (length (multiple-value-list 2097 (Assert (= 1 (length (multiple-value-list
2097 (cond ((multiple-value-function-returning-t))))) 2098 (cond ((multiple-value-function-returning-t))))))
2098 "Checking cond doesn't pass back multiple values in tests.") 2099 "Checking cond doesn't pass back multiple values in tests.")
2099 (Assert-equal (list nil pi e radians-to-degrees degrees-to-radians) 2100 (Assert (equal (list nil pi e radians-to-degrees degrees-to-radians)
2101 (multiple-value-list
2102 (cond (t (multiple-value-function-returning-nil)))))
2103 "Checking cond passes back multiple values in clauses.")
2104 (Assert (= 1 (length (multiple-value-list
2105 (prog1 (multiple-value-function-returning-nil)))))
2106 "Checking prog1 discards multiple values correctly.")
2107 (Assert (= 5 (length (multiple-value-list
2108 (multiple-value-prog1
2109 (multiple-value-function-returning-nil)))))
2110 "Checking multiple-value-prog1 passes back multiple values correctly.")
2111 (Assert (equal (list t pi e degrees-to-radians radians-to-degrees)
2100 (multiple-value-list 2112 (multiple-value-list
2101 (cond (t (multiple-value-function-returning-nil)))) 2113 (catch 'VoN61Lo4Y (function-throwing-multiple-values)))))
2102 "Checking cond passes back multiple values in clauses.") 2114 (Assert (equal (list t pi e degrees-to-radians radians-to-degrees)
2103 (Assert= 1 (length (multiple-value-list
2104 (prog1 (multiple-value-function-returning-nil))))
2105 "Checking prog1 discards multiple values correctly.")
2106 (Assert= 5 (length (multiple-value-list
2107 (multiple-value-prog1
2108 (multiple-value-function-returning-nil))))
2109 "Checking multiple-value-prog1 passes back multiple values correctly.")
2110 (Assert-equal (list t pi e degrees-to-radians radians-to-degrees)
2111 (multiple-value-list
2112 (catch 'VoN61Lo4Y (function-throwing-multiple-values))))
2113 (Assert-equal (list t pi e degrees-to-radians radians-to-degrees)
2114 (multiple-value-list 2115 (multiple-value-list
2115 (loop 2116 (loop
2116 for eye in `(a b c d ,e f g ,nil ,pi) 2117 for eye in `(a b c d ,e f g ,nil ,pi)
2117 do (when (null eye) 2118 do (when (null eye)
2118 (return (multiple-value-function-returning-t))))) 2119 (return (multiple-value-function-returning-t))))))
2119 "Checking #'loop passes back multiple values correctly.") 2120 "Checking #'loop passes back multiple values correctly.")
2120 (Assert 2121 (Assert
2121 (null (or)) 2122 (null (or))
2122 "Checking #'or behaves correctly with zero arguments.") 2123 "Checking #'or behaves correctly with zero arguments.")
2123 (Assert-eq t (and) 2124 (Assert (eq t (and))
2124 "Checking #'and behaves correctly with zero arguments.") 2125 "Checking #'and behaves correctly with zero arguments.")
2125 (Assert= (* 3.0 (- pi 3.0)) 2126 (Assert (= (* 3.0 (- pi 3.0))
2126 (letf (((values three one-four-one-five-nine) (floor pi))) 2127 (letf (((values three one-four-one-five-nine) (floor pi)))
2127 (* three one-four-one-five-nine)) 2128 (* three one-four-one-five-nine)))
2128 "checking letf handles #'values in a basic sense")) 2129 "checking letf handles #'values in a basic sense"))
2129 2130
2130 ;; #'equalp tests. 2131 ;; #'equalp tests.
2131 (let ((string-variable "aBcDeeFgH\u00Edj") 2132 (let ((string-variable "aBcDeeFgH\u00Edj")
2132 (eacute-character ?\u00E9) 2133 (eacute-character ?\u00E9)
2150 ;; -12345678901234567890123457890123457890123457890123457890123457890.0) 2151 ;; -12345678901234567890123457890123457890123457890123457890123457890.0)
2151 ))) 2152 )))
2152 (loop for li in equal-lists do 2153 (loop for li in equal-lists do
2153 (loop for (x . tail) on li do 2154 (loop for (x . tail) on li do
2154 (loop for y in tail do 2155 (loop for y in tail do
2155 (Assert-equalp x y) 2156 (Assert (equalp x y))
2156 (Assert-equalp y x))))) 2157 (Assert (equalp y x))))))
2157 2158
2158 (let ((diff-list 2159 (let ((diff-list
2159 `(0 1 2 3 1000 5000000000 5555555555555555555555555555555555555 2160 `(0 1 2 3 1000 5000000000 5555555555555555555555555555555555555
2160 -1 -2 -3 -1000 -5000000000 -5555555555555555555555555555555555555 2161 -1 -2 -3 -1000 -5000000000 -5555555555555555555555555555555555555
2161 1/2 1/3 2/3 8/2 355/113 (/ 3/2 0.2) (/ 3/2 0.7) 2162 1/2 1/3 2/3 8/2 355/113 (/ 3/2 0.2) (/ 3/2 0.7)
2162 55555555555555555555555555555555555555555/2718281828459045 2163 55555555555555555555555555555555555555555/2718281828459045
2163 0.111111111111111111111111111111111111111111111111111111111111111 2164 0.111111111111111111111111111111111111111111111111111111111111111
2164 1e+300 1e+301 -1e+300 -1e+301))) 2165 1e+300 1e+301 -1e+300 -1e+301)))
2165 (loop for (x . tail) on diff-list do 2166 (loop for (x . tail) on diff-list do
2166 (loop for y in tail do 2167 (loop for y in tail do
2167 (Assert-not-equalp x y) 2168 (Assert (not (equalp x y)))
2168 (Assert-not-equalp y x)))) 2169 (Assert (not (equalp y x))))))
2169 2170
2170 (Assert-equalp "hi there" "Hi There" 2171 (Assert (equalp "hi there" "Hi There")
2171 "checking equalp isn't case-sensitive") 2172 "checking equalp isn't case-sensitive")
2172 (Assert-equalp 99 99.0 2173 (Assert (equalp 99 99.0)
2173 "checking equalp compares numerical values of different types") 2174 "checking equalp compares numerical values of different types")
2174 (Assert (null (equalp 99 ?c)) 2175 (Assert (null (equalp 99 ?c))
2175 "checking equalp does not convert characters to numbers") 2176 "checking equalp does not convert characters to numbers")
2176 ;; Fixed in Hg d0ea57eb3de4. 2177 ;; Fixed in Hg d0ea57eb3de4.
2177 (Assert (null (equalp "hi there" [hi there])) 2178 (Assert (null (equalp "hi there" [hi there]))
2178 "checking equalp doesn't error with string and non-string") 2179 "checking equalp doesn't error with string and non-string")
2179 (Assert-equalp "ABCDEEFGH\u00CDJ" string-variable 2180 (Assert (equalp "ABCDEEFGH\u00CDJ" string-variable)
2180 "checking #'equalp is case-insensitive with an upcased constant") 2181 "checking #'equalp is case-insensitive with an upcased constant")
2181 (Assert-equalp "abcdeefgh\xedj" string-variable 2182 (Assert (equalp "abcdeefgh\xedj" string-variable)
2182 "checking #'equalp is case-insensitive with a downcased constant") 2183 "checking #'equalp is case-insensitive with a downcased constant")
2183 (Assert-equalp string-variable string-variable 2184 (Assert (equalp string-variable string-variable)
2184 "checking #'equalp works when handed the same string twice") 2185 "checking #'equalp works when handed the same string twice")
2185 (Assert-equalp string-variable "aBcDeeFgH\u00Edj" 2186 (Assert (equalp string-variable "aBcDeeFgH\u00Edj")
2186 "check #'equalp is case-insensitive with a variable-cased constant") 2187 "check #'equalp is case-insensitive with a variable-cased constant")
2187 (Assert-equalp "" (bit-vector) 2188 (Assert (equalp "" (bit-vector))
2188 "check empty string and empty bit-vector are #'equalp.") 2189 "check empty string and empty bit-vector are #'equalp.")
2189 (Assert-equalp (string) (bit-vector) 2190 (Assert (equalp (string) (bit-vector))
2190 "check empty string and empty bit-vector are #'equalp, no constants") 2191 "check empty string and empty bit-vector are #'equalp, no constants")
2191 (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e) 2192 (Assert (equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e))
2192 "check string and vector with same contents #'equalp") 2193 "check string and vector with same contents #'equalp")
2193 (Assert-equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) 2194 (Assert (equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e)
2194 (vector ?h ?i ?\ ?t ?h ?e ?r ?e) 2195 (vector ?h ?i ?\ ?t ?h ?e ?r ?e))
2195 "check string and vector with same contents #'equalp, no constants") 2196 "check string and vector with same contents #'equalp, no constants")
2196 (Assert-equalp [?h ?i ?\ ?t ?h ?e ?r ?e] 2197 (Assert (equalp [?h ?i ?\ ?t ?h ?e ?r ?e]
2197 (string ?h ?i ?\ ?t ?h ?e ?r ?e) 2198 (string ?h ?i ?\ ?t ?h ?e ?r ?e))
2198 "check string and vector with same contents #'equalp, vector constant") 2199 "check string and vector with same contents #'equalp, vector constant")
2199 (Assert-equalp [0 1.0 0.0 0 1] 2200 (Assert (equalp [0 1.0 0.0 0 1]
2200 (bit-vector 0 1 0 0 1) 2201 (bit-vector 0 1 0 0 1))
2201 "check vector and bit-vector with same contents #'equalp,\ 2202 "check vector and bit-vector with same contents #'equalp,\
2202 vector constant") 2203 vector constant")
2203 (Assert-not-equalp [0 2 0.0 0 1] 2204 (Assert (not (equalp [0 2 0.0 0 1]
2204 (bit-vector 0 1 0 0 1) 2205 (bit-vector 0 1 0 0 1)))
2205 "check vector and bit-vector with different contents not #'equalp,\ 2206 "check vector and bit-vector with different contents not #'equalp,\
2206 vector constant") 2207 vector constant")
2207 (Assert-equalp #*01001 2208 (Assert (equalp #*01001
2208 (vector 0 1.0 0.0 0 1) 2209 (vector 0 1.0 0.0 0 1))
2209 "check vector and bit-vector with same contents #'equalp,\ 2210 "check vector and bit-vector with same contents #'equalp,\
2210 bit-vector constant") 2211 bit-vector constant")
2211 (Assert-equalp ?\u00E9 Eacute-character 2212 (Assert (equalp ?\u00E9 Eacute-character)
2212 "checking characters are case-insensitive, one constant") 2213 "checking characters are case-insensitive, one constant")
2213 (Assert-not-equalp ?\u00E9 (aref (format "%c" ?a) 0) 2214 (Assert (not (equalp ?\u00E9 (aref (format "%c" ?a) 0)))
2214 "checking distinct characters are not equalp, one constant") 2215 "checking distinct characters are not equalp, one constant")
2215 (Assert-equalp t (and) 2216 (Assert (equalp t (and))
2216 "checking symbols are correctly #'equalp") 2217 "checking symbols are correctly #'equalp")
2217 (Assert-not-equalp t (or nil '#:t) 2218 (Assert (not (equalp t (or nil '#:t)))
2218 "checking distinct symbols with the same name are not #'equalp") 2219 "checking distinct symbols with the same name are not #'equalp")
2219 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) 2220 (Assert (equalp #s(char-table type generic data (?\u0080 "hi-there"))
2220 (let ((aragh (make-char-table 'generic))) 2221 (let ((aragh (make-char-table 'generic)))
2221 (put-char-table ?\u0080 "hi-there" aragh) 2222 (put-char-table ?\u0080 "hi-there" aragh)
2222 aragh) 2223 aragh))
2223 "checking #'equalp succeeds correctly, char-tables") 2224 "checking #'equalp succeeds correctly, char-tables")
2224 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) 2225 (Assert (equalp #s(char-table type generic data (?\u0080 "hi-there"))
2225 (let ((aragh (make-char-table 'generic))) 2226 (let ((aragh (make-char-table 'generic)))
2226 (put-char-table ?\u0080 "HI-THERE" aragh) 2227 (put-char-table ?\u0080 "HI-THERE" aragh)
2227 aragh) 2228 aragh))
2228 "checking #'equalp succeeds correctly, char-tables") 2229 "checking #'equalp succeeds correctly, char-tables")
2229 (Assert-not-equalp #s(char-table type generic data (?\u0080 "hi-there")) 2230 (Assert (not (equalp #s(char-table type generic data (?\u0080 "hi-there"))
2230 (let ((aragh (make-char-table 'generic))) 2231 (let ((aragh (make-char-table 'generic)))
2231 (put-char-table ?\u0080 "hi there" aragh) 2232 (put-char-table ?\u0080 "hi there" aragh)
2232 aragh) 2233 aragh)))
2233 "checking #'equalp fails correctly, char-tables")) 2234 "checking #'equalp fails correctly, char-tables")
2234 2235
2235 ;; There are more tests available for equalp here: 2236 ;; There are more tests available for equalp here:
2236 ;; 2237 ;;
2237 ;; http://www.parhasard.net/xemacs/equalp-tests.el 2238 ;; http://www.parhasard.net/xemacs/equalp-tests.el
2238 ;; 2239 ;;
2277 (1+ most-positive-fixnum)) 2278 (1+ most-positive-fixnum))
2278 (1-most-negative-fixnum () 2279 (1-most-negative-fixnum ()
2279 (1- most-negative-fixnum)) 2280 (1- most-negative-fixnum))
2280 (*-2-most-positive-fixnum () 2281 (*-2-most-positive-fixnum ()
2281 (* 2 most-positive-fixnum))) 2282 (* 2 most-positive-fixnum)))
2282 (Assert-eq 2283 (Assert (eq
2283 (member* (1+ most-positive-fixnum) member*-list) 2284 (member* (1+ most-positive-fixnum) member*-list)
2284 (member* (1+ most-positive-fixnum) member*-list :test #'eql) 2285 (member* (1+ most-positive-fixnum) member*-list :test #'eql))
2285 "checking #'member* correct if #'eql not explicitly specified") 2286 "checking #'member* correct if #'eql not explicitly specified")
2286 (Assert-eq 2287 (Assert (eq
2287 (assoc* (1+ most-positive-fixnum) assoc*-list) 2288 (assoc* (1+ most-positive-fixnum) assoc*-list)
2288 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'eql) 2289 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'eql))
2289 "checking #'assoc* correct if #'eql not explicitly specified") 2290 "checking #'assoc* correct if #'eql not explicitly specified")
2290 (Assert-eq 2291 (Assert (eq
2291 (rassoc* (1- most-negative-fixnum) assoc*-list) 2292 (rassoc* (1- most-negative-fixnum) assoc*-list)
2292 (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql) 2293 (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql))
2293 "checking #'rassoc* correct if #'eql not explicitly specified") 2294 "checking #'rassoc* correct if #'eql not explicitly specified")
2294 (Assert-eql (1+most-positive-fixnum) (1+ most-positive-fixnum) 2295 (Assert (eql (1+most-positive-fixnum) (1+ most-positive-fixnum))
2295 "checking #'eql handles a bignum literal properly.") 2296 "checking #'eql handles a bignum literal properly.")
2296 (Assert-eq 2297 (Assert (eq
2297 (member* (1+most-positive-fixnum) member*-list) 2298 (member* (1+most-positive-fixnum) member*-list)
2298 (member* (1+ most-positive-fixnum) member*-list :test #'equal) 2299 (member* (1+ most-positive-fixnum) member*-list :test #'equal))
2299 "checking #'member* compiler macro correct with literal bignum") 2300 "checking #'member* compiler macro correct with literal bignum")
2300 (Assert-eq 2301 (Assert (eq
2301 (assoc* (1+most-positive-fixnum) assoc*-list) 2302 (assoc* (1+most-positive-fixnum) assoc*-list)
2302 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'equal) 2303 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'equal))
2303 "checking #'assoc* compiler macro correct with literal bignum") 2304 "checking #'assoc* compiler macro correct with literal bignum")
2304 (puthash (setq hashed-bignum (*-2-most-positive-fixnum)) 2305 (puthash (setq hashed-bignum (*-2-most-positive-fixnum))
2305 (gensym) hashing) 2306 (gensym) hashing)
2306 (Assert-eq 2307 (Assert (eq
2307 (gethash (* 2 most-positive-fixnum) hashing) 2308 (gethash (* 2 most-positive-fixnum) hashing)
2308 (gethash hashed-bignum hashing) 2309 (gethash hashed-bignum hashing))
2309 "checking hashing works correctly with #'eql tests and bignums")))) 2310 "checking hashing works correctly with #'eql tests and bignums"))))
2310 2311
2311 ;;; end of lisp-tests.el 2312 ;;; end of lisp-tests.el