Mercurial > hg > xemacs-beta
annotate tests/automated/lisp-tests.el @ 4605:c786c3fd0740
Listen to the byte-compiler, core Lisp.
lisp/ChangeLog addition:
2009-02-07 Aidan Kehoe <kehoea@parhasard.net>
* descr-text.el (describe-text-sexp):
pp is in packages, use cl-prettyprint instead.
* mule/mule-coding.el (make-8-bit-generate-helper):
Don't uselessly bind args-out-of-range, thank you the byte
compiler.
* mule/mule-coding.el (8-bit-fixed-query-coding-region):
Don't uselessly bind previous-fail, thank you the byte compiler.
* tty-init.el (make-device-early-tty-entry-point):
Set make-device-early-tty-entry-point-called-p, not
pre-tty-win-initted, thank you the byte compiler.
* unicode.el (unicode-query-coding-region):
Don't uselessly bind invalid-sequence-p, thank you the
byte-compiler.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 07 Feb 2009 18:31:21 +0000 |
| parents | 00ed9903a988 |
| children | 1e3cf11fa27d |
| rev | line source |
|---|---|
| 428 | 1 ;; Copyright (C) 1998 Free Software Foundation, Inc. |
| 2 | |
| 3 ;; Author: Martin Buchholz <martin@xemacs.org> | |
| 4 ;; Maintainer: Martin Buchholz <martin@xemacs.org> | |
| 5 ;; Created: 1998 | |
| 6 ;; Keywords: tests | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
| 10 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 11 ;; under the terms of the GNU General Public License as published by | |
| 12 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 13 ;; any later version. | |
| 14 | |
| 15 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 18 ;; General Public License for more details. | |
| 19 | |
| 20 ;; You should have received a copy of the GNU General Public License | |
| 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 23 ;; 02111-1307, USA. | |
| 24 | |
| 25 ;;; Synched up with: Not in FSF. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;;; Test basic Lisp engine functionality | |
| 30 ;;; See test-harness.el for instructions on how to run these tests. | |
| 31 | |
| 32 (eval-when-compile | |
| 33 (condition-case nil | |
| 34 (require 'test-harness) | |
| 35 (file-error | |
| 36 (push "." load-path) | |
| 37 (when (and (boundp 'load-file-name) (stringp load-file-name)) | |
| 38 (push (file-name-directory load-file-name) load-path)) | |
| 39 (require 'test-harness)))) | |
| 40 | |
| 41 (Check-Error wrong-number-of-arguments (setq setq-test-foo)) | |
| 42 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar)) | |
| 43 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo)) | |
| 44 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar)) | |
| 45 (Assert (eq (setq) nil)) | |
| 46 (Assert (eq (setq-default) nil)) | |
| 47 (Assert (eq (setq setq-test-foo 42) 42)) | |
| 48 (Assert (eq (setq-default setq-test-foo 42) 42)) | |
| 49 (Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99)) | |
| 50 (Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99)) | |
| 51 | |
| 52 (macrolet ((test-setq (expected-result &rest body) | |
| 53 `(progn | |
| 54 (defun test-setq-fun () ,@body) | |
| 55 (Assert (eq ,expected-result (test-setq-fun))) | |
| 56 (byte-compile 'test-setq-fun) | |
| 57 (Assert (eq ,expected-result (test-setq-fun)))))) | |
| 58 (test-setq nil (setq)) | |
| 59 (test-setq nil (setq-default)) | |
| 60 (test-setq 42 (setq test-setq-var 42)) | |
| 61 (test-setq 42 (setq-default test-setq-var 42)) | |
| 62 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42)) | |
| 63 (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42)) | |
| 64 ) | |
| 65 | |
| 66 (let ((my-vector [1 2 3 4]) | |
| 67 (my-bit-vector (bit-vector 1 0 1 0)) | |
| 68 (my-string "1234") | |
| 69 (my-list '(1 2 3 4))) | |
| 70 | |
| 71 ;;(Assert (fooooo)) ;; Generate Other failure | |
| 72 ;;(Assert (eq 1 2)) ;; Generate Assertion failure | |
| 73 | |
| 74 (dolist (sequence (list my-vector my-bit-vector my-string my-list)) | |
| 75 (Assert (sequencep sequence)) | |
| 76 (Assert (eq 4 (length sequence)))) | |
| 77 | |
| 78 (dolist (array (list my-vector my-bit-vector my-string)) | |
| 79 (Assert (arrayp array))) | |
| 80 | |
| 81 (Assert (eq (elt my-vector 0) 1)) | |
| 82 (Assert (eq (elt my-bit-vector 0) 1)) | |
| 83 (Assert (eq (elt my-string 0) ?1)) | |
| 84 (Assert (eq (elt my-list 0) 1)) | |
| 85 | |
| 86 (fillarray my-vector 5) | |
| 87 (fillarray my-bit-vector 1) | |
| 88 (fillarray my-string ?5) | |
| 89 | |
| 90 (dolist (array (list my-vector my-bit-vector)) | |
| 91 (Assert (eq 4 (length array)))) | |
| 92 | |
| 93 (Assert (eq (elt my-vector 0) 5)) | |
| 94 (Assert (eq (elt my-bit-vector 0) 1)) | |
| 95 (Assert (eq (elt my-string 0) ?5)) | |
| 96 | |
| 97 (Assert (eq (elt my-vector 3) 5)) | |
| 98 (Assert (eq (elt my-bit-vector 3) 1)) | |
| 99 (Assert (eq (elt my-string 3) ?5)) | |
| 100 | |
| 101 (fillarray my-bit-vector 0) | |
| 102 (Assert (eq 4 (length my-bit-vector))) | |
| 103 (Assert (eq (elt my-bit-vector 2) 0)) | |
| 104 ) | |
| 105 | |
| 106 (defun make-circular-list (length) | |
| 107 "Create evil emacs-crashing circular list of length LENGTH" | |
| 108 (let ((circular-list | |
| 109 (make-list | |
| 110 length | |
| 111 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))) | |
| 112 (setcdr (last circular-list) circular-list) | |
| 113 circular-list)) | |
| 114 | |
| 115 ;;----------------------------------------------------- | |
| 116 ;; Test `nconc' | |
| 117 ;;----------------------------------------------------- | |
| 118 (defun make-list-012 () (list 0 1 2)) | |
| 119 | |
| 120 (Check-Error wrong-type-argument (nconc 'foo nil)) | |
| 121 | |
| 122 (dolist (length '(1 2 3 4 1000 2000)) | |
| 123 (Check-Error circular-list (nconc (make-circular-list length) 'foo)) | |
| 124 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo)) | |
| 125 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo))) | |
| 126 | |
| 127 (Assert (eq (nconc) nil)) | |
| 128 (Assert (eq (nconc nil) nil)) | |
| 129 (Assert (eq (nconc nil nil) nil)) | |
| 130 (Assert (eq (nconc nil nil nil) nil)) | |
| 131 | |
| 132 (let ((x (make-list-012))) (Assert (eq (nconc nil x) x))) | |
| 133 (let ((x (make-list-012))) (Assert (eq (nconc x nil) x))) | |
| 134 (let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x))) | |
| 135 (let ((x (make-list-012))) (Assert (eq (nconc x) x))) | |
| 136 (let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x))) | |
| 137 | |
| 138 (Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6))) | |
| 139 | |
| 140 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) | |
| 141 (Assert (eq (length y) 6)) | |
| 142 (Assert (eq (nth 3 y) 3))) | |
| 143 | |
| 144 ;;----------------------------------------------------- | |
| 145 ;; Test `last' | |
| 146 ;;----------------------------------------------------- | |
| 147 (Check-Error wrong-type-argument (last 'foo)) | |
| 148 (Check-Error wrong-number-of-arguments (last)) | |
| 149 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1)) | |
| 150 (Check-Error circular-list (last (make-circular-list 1))) | |
| 151 (Check-Error circular-list (last (make-circular-list 2000))) | |
| 152 (let ((x (list 0 1 2 3))) | |
| 153 (Assert (eq (last nil) nil)) | |
| 154 (Assert (eq (last x 0) nil)) | |
| 155 (Assert (eq (last x ) (cdddr x))) | |
| 156 (Assert (eq (last x 1) (cdddr x))) | |
| 157 (Assert (eq (last x 2) (cddr x))) | |
| 158 (Assert (eq (last x 3) (cdr x))) | |
| 159 (Assert (eq (last x 4) x)) | |
| 160 (Assert (eq (last x 9) x)) | |
| 161 (Assert (eq (last '(1 . 2) 0) 2)) | |
| 162 ) | |
| 163 | |
| 164 ;;----------------------------------------------------- | |
| 165 ;; Test `butlast' and `nbutlast' | |
| 166 ;;----------------------------------------------------- | |
| 167 (Check-Error wrong-type-argument (butlast 'foo)) | |
| 168 (Check-Error wrong-type-argument (nbutlast 'foo)) | |
| 169 (Check-Error wrong-number-of-arguments (butlast)) | |
| 170 (Check-Error wrong-number-of-arguments (nbutlast)) | |
| 171 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1)) | |
| 172 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1)) | |
| 173 (Check-Error circular-list (butlast (make-circular-list 1))) | |
| 174 (Check-Error circular-list (nbutlast (make-circular-list 1))) | |
| 175 (Check-Error circular-list (butlast (make-circular-list 2000))) | |
| 176 (Check-Error circular-list (nbutlast (make-circular-list 2000))) | |
| 177 | |
| 178 (let* ((x (list 0 1 2 3)) | |
| 179 (y (butlast x)) | |
| 180 (z (nbutlast x))) | |
| 181 (Assert (eq z x)) | |
| 182 (Assert (not (eq y x))) | |
| 183 (Assert (equal y '(0 1 2))) | |
| 184 (Assert (equal z y))) | |
| 185 | |
| 186 (let* ((x (list 0 1 2 3 4)) | |
| 187 (y (butlast x 2)) | |
| 188 (z (nbutlast x 2))) | |
| 189 (Assert (eq z x)) | |
| 190 (Assert (not (eq y x))) | |
| 191 (Assert (equal y '(0 1 2))) | |
| 192 (Assert (equal z y))) | |
| 193 | |
| 194 (let* ((x (list 0 1 2 3)) | |
| 195 (y (butlast x 0)) | |
| 196 (z (nbutlast x 0))) | |
| 197 (Assert (eq z x)) | |
| 198 (Assert (not (eq y x))) | |
| 199 (Assert (equal y '(0 1 2 3))) | |
| 200 (Assert (equal z y))) | |
| 201 | |
| 202 (Assert (eq (butlast '(x)) nil)) | |
| 203 (Assert (eq (nbutlast '(x)) nil)) | |
| 204 (Assert (eq (butlast '()) nil)) | |
| 205 (Assert (eq (nbutlast '()) nil)) | |
| 206 | |
| 207 ;;----------------------------------------------------- | |
| 208 ;; Test `copy-list' | |
| 209 ;;----------------------------------------------------- | |
| 210 (Check-Error wrong-type-argument (copy-list 'foo)) | |
| 211 (Check-Error wrong-number-of-arguments (copy-list)) | |
| 212 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) | |
| 213 (Check-Error circular-list (copy-list (make-circular-list 1))) | |
| 214 (Check-Error circular-list (copy-list (make-circular-list 2000))) | |
| 215 (Assert (eq '() (copy-list '()))) | |
| 216 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) | |
| 217 (let ((y (copy-list x))) | |
| 218 (Assert (and (equal x y) (not (eq x y)))))) | |
| 219 | |
| 220 ;;----------------------------------------------------- | |
| 221 ;; Arithmetic operations | |
| 222 ;;----------------------------------------------------- | |
| 223 | |
| 224 ;; Test `+' | |
| 225 (Assert (eq (+ 1 1) 2)) | |
| 226 (Assert (= (+ 1.0 1.0) 2.0)) | |
| 227 (Assert (= (+ 1.0 3.0 0.0) 4.0)) | |
| 228 (Assert (= (+ 1 1.0) 2.0)) | |
| 229 (Assert (= (+ 1.0 1) 2.0)) | |
| 230 (Assert (= (+ 1.0 1 1) 3.0)) | |
| 231 (Assert (= (+ 1 1 1.0) 3.0)) | |
| 1983 | 232 (if (featurep 'bignum) |
| 233 (progn | |
| 234 (Assert (bignump (1+ most-positive-fixnum))) | |
| 235 (Assert (eq most-positive-fixnum (1- (1+ most-positive-fixnum)))) | |
| 236 (Assert (bignump (+ most-positive-fixnum 1))) | |
| 237 (Assert (eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1))) | |
| 238 (Assert (= (1+ most-positive-fixnum) (- most-negative-fixnum))) | |
| 239 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum) | |
| 240 3)))) | |
| 241 (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum)) | |
| 242 (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum))) | |
| 243 | |
| 244 (when (featurep 'ratio) | |
| 245 (let ((threefourths (read "3/4")) | |
| 246 (threehalfs (read "3/2")) | |
| 247 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
| 248 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum)) | |
| 249 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
| 250 (Assert (= negone -1)) | |
| 251 (Assert (= threehalfs (+ threefourths threefourths))) | |
| 252 (Assert (zerop (+ bigpos bigneg))))) | |
| 428 | 253 |
| 254 ;; Test `-' | |
| 255 (Check-Error wrong-number-of-arguments (-)) | |
| 256 (Assert (eq (- 0) 0)) | |
| 257 (Assert (eq (- 1) -1)) | |
| 258 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) | |
| 259 (Assert (= (+ 1 one) 2)) | |
| 260 (Assert (= (+ one) 1)) | |
| 261 (Assert (= (+ one) one)) | |
| 262 (Assert (= (- one) -1)) | |
| 263 (Assert (= (- one one) 0)) | |
| 264 (Assert (= (- one one one) -1)) | |
| 464 | 265 (Assert (= (- 0 one) -1)) |
| 266 (Assert (= (- 0 one one) -2)) | |
| 428 | 267 (Assert (= (+ one 1) 2)) |
| 268 (dolist (zero '(0 0.0 ?\0)) | |
| 2056 | 269 (Assert (= (+ 1 zero) 1) zero) |
| 270 (Assert (= (+ zero 1) 1) zero) | |
| 271 (Assert (= (- zero) zero) zero) | |
| 272 (Assert (= (- zero) 0) zero) | |
| 273 (Assert (= (- zero zero) 0) zero) | |
| 274 (Assert (= (- zero one one) -2) zero))) | |
| 428 | 275 |
| 276 (Assert (= (- 1.5 1) .5)) | |
| 277 (Assert (= (- 1 1.5) (- .5))) | |
| 278 | |
| 1983 | 279 (if (featurep 'bignum) |
| 280 (progn | |
| 281 (Assert (bignump (1- most-negative-fixnum))) | |
| 282 (Assert (eq most-negative-fixnum (1+ (1- most-negative-fixnum)))) | |
| 283 (Assert (bignump (- most-negative-fixnum 1))) | |
| 284 (Assert (eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1))) | |
| 285 (Assert (= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2))) | |
| 286 (Assert (eq (- (- most-positive-fixnum most-negative-fixnum) | |
| 287 (* 2 most-positive-fixnum)) | |
| 288 1))) | |
| 289 (Assert (eq (1- most-negative-fixnum) most-positive-fixnum)) | |
| 290 (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum))) | |
| 291 | |
| 292 (when (featurep 'ratio) | |
| 293 (let ((threefourths (read "3/4")) | |
| 294 (threehalfs (read "3/2")) | |
| 295 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
| 296 (bigneg (div most-positive-fixnum most-negative-fixnum)) | |
| 297 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
| 298 (Assert (= (- negone) 1)) | |
| 299 (Assert (= threefourths (- threehalfs threefourths))) | |
| 300 (Assert (= (- bigpos bigneg) 2)))) | |
| 428 | 301 |
| 302 ;; Test `/' | |
| 303 | |
| 304 ;; Test division by zero errors | |
| 305 (dolist (zero '(0 0.0 ?\0)) | |
| 306 (Check-Error arith-error (/ zero)) | |
| 307 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42))) | |
| 308 (Check-Error arith-error (/ n1 zero)) | |
| 309 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3))) | |
| 310 (Check-Error arith-error (/ n1 n2 zero))))) | |
| 311 | |
| 312 ;; Other tests for `/' | |
| 313 (Check-Error wrong-number-of-arguments (/)) | |
| 314 (let (x) | |
| 315 (Assert (= (/ (setq x 2)) 0)) | |
| 316 (Assert (= (/ (setq x 2.0)) 0.5))) | |
| 317 | |
| 318 (dolist (six '(6 6.0 ?\06)) | |
| 319 (dolist (two '(2 2.0 ?\02)) | |
| 320 (dolist (three '(3 3.0 ?\03)) | |
| 2056 | 321 (Assert (= (/ six two) three) (list six two three))))) |
| 428 | 322 |
| 323 (dolist (three '(3 3.0 ?\03)) | |
| 2056 | 324 (Assert (= (/ three 2.0) 1.5) three)) |
| 428 | 325 (dolist (two '(2 2.0 ?\02)) |
| 2056 | 326 (Assert (= (/ 3.0 two) 1.5) two)) |
| 428 | 327 |
| 1983 | 328 (when (featurep 'bignum) |
| 329 (let* ((million 1000000) | |
| 330 (billion (* million 1000)) ;; American, not British, billion | |
| 331 (trillion (* billion 1000))) | |
| 332 (Assert (= (/ billion 1000) (/ trillion million) million 1000000.0)) | |
| 333 (Assert (= (/ billion -1000) (/ trillion (- million)) (- million))) | |
| 334 (Assert (= (/ trillion 1000) billion 1000000000.0)) | |
| 335 (Assert (= (/ trillion -1000) (- billion) -1000000000.0)) | |
| 336 (Assert (= (/ trillion 10) (* 100 billion) 100000000000.0)) | |
| 337 (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0)))) | |
| 338 | |
| 339 (when (featurep 'ratio) | |
| 340 (let ((half (div 1 2)) | |
| 341 (fivefourths (div 5 4)) | |
| 342 (fivehalfs (div 5 2))) | |
| 343 (Assert (= half (read "3000000000/6000000000"))) | |
| 344 (Assert (= (/ fivehalfs fivefourths) 2)) | |
| 345 (Assert (= (/ fivefourths fivehalfs) half)) | |
| 346 (Assert (= (- half) (read "-3000000000/6000000000"))) | |
| 347 (Assert (= (/ fivehalfs (- fivefourths)) -2)) | |
| 348 (Assert (= (/ (- fivefourths) fivehalfs) (- half))))) | |
| 349 | |
| 428 | 350 ;; Test `*' |
| 351 (Assert (= 1 (*))) | |
| 352 | |
| 353 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
| 2056 | 354 (Assert (= 1 (* one)) one)) |
| 428 | 355 |
| 356 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 357 (Assert (= 2 (* two)) two)) |
| 428 | 358 |
| 359 (dolist (six '(6 6.0 ?\06)) | |
| 360 (dolist (two '(2 2.0 ?\02)) | |
| 361 (dolist (three '(3 3.0 ?\03)) | |
| 2056 | 362 (Assert (= (* three two) six) (list three two six))))) |
| 428 | 363 |
| 364 (dolist (three '(3 3.0 ?\03)) | |
| 365 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 366 (Assert (= (* 1.5 two) three) (list two three)) |
| 428 | 367 (dolist (five '(5 5.0 ?\05)) |
| 2056 | 368 (Assert (= 30 (* five two three)) (list five two three))))) |
| 428 | 369 |
| 1983 | 370 (when (featurep 'bignum) |
| 371 (let ((64K 65536)) | |
| 372 (Assert (= (* 64K 64K) (read "4294967296"))) | |
| 373 (Assert (= (* (- 64K) 64K) (read "-4294967296"))) | |
| 374 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum)))) | |
| 375 | |
| 376 (when (featurep 'ratio) | |
| 377 (let ((half (div 1 2)) | |
| 378 (fivefourths (div 5 4)) | |
| 379 (twofifths (div 2 5))) | |
| 380 (Assert (= (* fivefourths twofifths) half)) | |
| 381 (Assert (= (* half twofifths) (read "3/15"))))) | |
| 382 | |
| 428 | 383 ;; Test `+' |
| 384 (Assert (= 0 (+))) | |
| 385 | |
| 386 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
| 2056 | 387 (Assert (= 1 (+ one)) one)) |
| 428 | 388 |
| 389 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 390 (Assert (= 2 (+ two)) two)) |
| 428 | 391 |
| 392 (dolist (five '(5 5.0 ?\05)) | |
| 393 (dolist (two '(2 2.0 ?\02)) | |
| 394 (dolist (three '(3 3.0 ?\03)) | |
| 2056 | 395 (Assert (= (+ three two) five) (list three two five)) |
| 396 (Assert (= 10 (+ five two three)) (list five two three))))) | |
| 428 | 397 |
| 398 ;; Test `max', `min' | |
| 399 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
| 2056 | 400 (Assert (= one (max one)) one) |
| 401 (Assert (= one (max one one)) one) | |
| 402 (Assert (= one (max one one one)) one) | |
| 403 (Assert (= one (min one)) one) | |
| 404 (Assert (= one (min one one)) one) | |
| 405 (Assert (= one (min one one one)) one) | |
| 428 | 406 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) |
| 2056 | 407 (Assert (= one (min one two)) (list one two)) |
| 408 (Assert (= one (min one two two)) (list one two)) | |
| 409 (Assert (= one (min two two one)) (list one two)) | |
| 410 (Assert (= two (max one two)) (list one two)) | |
| 411 (Assert (= two (max one two two)) (list one two)) | |
| 412 (Assert (= two (max two two one)) (list one two)))) | |
| 428 | 413 |
| 1983 | 414 (when (featurep 'bignum) |
| 415 (let ((big (1+ most-positive-fixnum)) | |
| 416 (small (1- most-negative-fixnum))) | |
| 417 (Assert (= big (max 1 1000000.0 most-positive-fixnum big))) | |
| 418 (Assert (= small (min -1 -1000000.0 most-negative-fixnum small))))) | |
| 419 | |
| 420 (when (featurep 'ratio) | |
| 421 (let* ((big (1+ most-positive-fixnum)) | |
| 422 (small (1- most-negative-fixnum)) | |
| 423 (bigr (div (* 5 (1+ most-positive-fixnum)) 4)) | |
| 424 (smallr (- bigr))) | |
| 425 (Assert (= bigr (max 1 1000000.0 most-positive-fixnum big bigr))) | |
| 426 (Assert (= smallr (min -1 -1000000.0 most-negative-fixnum small smallr))))) | |
| 427 | |
| 446 | 428 ;; The byte compiler has special handling for these constructs: |
| 429 (let ((three 3) (five 5)) | |
| 430 (Assert (= (+ three five 1) 9)) | |
| 431 (Assert (= (+ 1 three five) 9)) | |
| 432 (Assert (= (+ three five -1) 7)) | |
| 433 (Assert (= (+ -1 three five) 7)) | |
| 434 (Assert (= (+ three 1) 4)) | |
| 435 (Assert (= (+ three -1) 2)) | |
| 436 (Assert (= (+ -1 three) 2)) | |
| 437 (Assert (= (+ -1 three) 2)) | |
| 438 (Assert (= (- three five 1) -3)) | |
| 439 (Assert (= (- 1 three five) -7)) | |
| 440 (Assert (= (- three five -1) -1)) | |
| 441 (Assert (= (- -1 three five) -9)) | |
| 442 (Assert (= (- three 1) 2)) | |
| 443 (Assert (= (- three 2 1) 0)) | |
| 444 (Assert (= (- 2 three 1) -2)) | |
| 445 (Assert (= (- three -1) 4)) | |
| 446 (Assert (= (- three 0) 3)) | |
| 447 (Assert (= (- three 0 five) -2)) | |
| 448 (Assert (= (- 0 three 0 five) -8)) | |
| 449 (Assert (= (- 0 three five) -8)) | |
| 450 (Assert (= (* three 2) 6)) | |
| 451 (Assert (= (* three -1 five) -15)) | |
| 452 (Assert (= (* three 1 five) 15)) | |
| 453 (Assert (= (* three 0 five) 0)) | |
| 454 (Assert (= (* three 2 five) 30)) | |
| 455 (Assert (= (/ three 1) 3)) | |
| 456 (Assert (= (/ three -1) -3)) | |
| 457 (Assert (= (/ (* five five) 2 2) 6)) | |
| 458 (Assert (= (/ 64 five 2) 6))) | |
| 459 | |
| 460 | |
| 428 | 461 ;;----------------------------------------------------- |
| 462 ;; Logical bit-twiddling operations | |
| 463 ;;----------------------------------------------------- | |
| 464 (Assert (= (logxor) 0)) | |
| 465 (Assert (= (logior) 0)) | |
| 466 (Assert (= (logand) -1)) | |
| 467 | |
| 468 (Check-Error wrong-type-argument (logxor 3.0)) | |
| 469 (Check-Error wrong-type-argument (logior 3.0)) | |
| 470 (Check-Error wrong-type-argument (logand 3.0)) | |
| 471 | |
| 472 (dolist (three '(3 ?\03)) | |
| 2056 | 473 (Assert (eq 3 (logand three)) three) |
| 474 (Assert (eq 3 (logxor three)) three) | |
| 475 (Assert (eq 3 (logior three)) three) | |
| 476 (Assert (eq 3 (logand three three)) three) | |
| 477 (Assert (eq 0 (logxor three three)) three) | |
| 478 (Assert (eq 3 (logior three three))) three) | |
| 428 | 479 |
| 480 (dolist (one `(1 ?\01 ,(Int-to-Marker 1))) | |
| 481 (dolist (two '(2 ?\02)) | |
| 2056 | 482 (Assert (eq 0 (logand one two)) (list one two)) |
| 483 (Assert (eq 3 (logior one two)) (list one two)) | |
| 484 (Assert (eq 3 (logxor one two)) (list one two))) | |
| 428 | 485 (dolist (three '(3 ?\03)) |
| 2056 | 486 (Assert (eq 1 (logand one three)) (list one three)) |
| 487 (Assert (eq 3 (logior one three)) (list one three)) | |
| 488 (Assert (eq 2 (logxor one three)) (list one three)))) | |
| 428 | 489 |
| 490 ;;----------------------------------------------------- | |
| 491 ;; Test `%', mod | |
| 492 ;;----------------------------------------------------- | |
| 493 (Check-Error wrong-number-of-arguments (%)) | |
| 494 (Check-Error wrong-number-of-arguments (% 1)) | |
| 495 (Check-Error wrong-number-of-arguments (% 1 2 3)) | |
| 496 | |
| 497 (Check-Error wrong-number-of-arguments (mod)) | |
| 498 (Check-Error wrong-number-of-arguments (mod 1)) | |
| 499 (Check-Error wrong-number-of-arguments (mod 1 2 3)) | |
| 500 | |
| 501 (Check-Error wrong-type-argument (% 10.0 2)) | |
| 502 (Check-Error wrong-type-argument (% 10 2.0)) | |
| 503 | |
| 2056 | 504 (flet ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x)) |
| 505 (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) | |
| 506 (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) | |
| 2075 | 507 (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x)) |
| 508 (test5 (x) (Assert (eql (% x -17) (% (- x) 17))) x)) | |
| 2056 | 509 (test1 most-negative-fixnum) |
| 510 (if (featurep 'bignum) | |
| 2075 | 511 (progn |
| 512 (test2 most-negative-fixnum) | |
| 513 (test4 most-negative-fixnum)) | |
| 514 (test3 most-negative-fixnum) | |
| 515 (test5 most-negative-fixnum)) | |
| 2056 | 516 (test1 most-positive-fixnum) |
| 517 (test2 most-positive-fixnum) | |
| 518 (test4 most-positive-fixnum) | |
| 519 (dotimes (j 30) | |
| 520 (let ((x (random))) | |
| 521 (if (eq x most-negative-fixnum) (setq x (1+ x))) | |
| 522 (if (eq x most-positive-fixnum) (setq x (1- x))) | |
| 523 (test1 x) | |
| 524 (test2 x) | |
| 525 (test4 x)))) | |
| 428 | 526 |
| 527 (macrolet | |
| 528 ((division-test (seven) | |
| 529 `(progn | |
| 530 (Assert (eq (% ,seven 2) 1)) | |
| 531 (Assert (eq (% ,seven -2) 1)) | |
| 532 (Assert (eq (% (- ,seven) 2) -1)) | |
| 533 (Assert (eq (% (- ,seven) -2) -1)) | |
| 534 | |
| 535 (Assert (eq (% ,seven 4) 3)) | |
| 536 (Assert (eq (% ,seven -4) 3)) | |
| 537 (Assert (eq (% (- ,seven) 4) -3)) | |
| 538 (Assert (eq (% (- ,seven) -4) -3)) | |
| 539 | |
| 540 (Assert (eq (% 35 ,seven) 0)) | |
| 541 (Assert (eq (% -35 ,seven) 0)) | |
| 542 (Assert (eq (% 35 (- ,seven)) 0)) | |
| 543 (Assert (eq (% -35 (- ,seven)) 0)) | |
| 544 | |
| 545 (Assert (eq (mod ,seven 2) 1)) | |
| 546 (Assert (eq (mod ,seven -2) -1)) | |
| 547 (Assert (eq (mod (- ,seven) 2) 1)) | |
| 548 (Assert (eq (mod (- ,seven) -2) -1)) | |
| 549 | |
| 550 (Assert (eq (mod ,seven 4) 3)) | |
| 551 (Assert (eq (mod ,seven -4) -1)) | |
| 552 (Assert (eq (mod (- ,seven) 4) 1)) | |
| 553 (Assert (eq (mod (- ,seven) -4) -3)) | |
| 554 | |
| 555 (Assert (eq (mod 35 ,seven) 0)) | |
| 556 (Assert (eq (mod -35 ,seven) 0)) | |
| 557 (Assert (eq (mod 35 (- ,seven)) 0)) | |
| 558 (Assert (eq (mod -35 (- ,seven)) 0)) | |
| 559 | |
| 560 (Assert (= (mod ,seven 2.0) 1.0)) | |
| 561 (Assert (= (mod ,seven -2.0) -1.0)) | |
| 562 (Assert (= (mod (- ,seven) 2.0) 1.0)) | |
| 563 (Assert (= (mod (- ,seven) -2.0) -1.0)) | |
| 564 | |
| 565 (Assert (= (mod ,seven 4.0) 3.0)) | |
| 566 (Assert (= (mod ,seven -4.0) -1.0)) | |
| 567 (Assert (= (mod (- ,seven) 4.0) 1.0)) | |
| 568 (Assert (= (mod (- ,seven) -4.0) -3.0)) | |
| 569 | |
| 570 (Assert (eq (% 0 ,seven) 0)) | |
| 571 (Assert (eq (% 0 (- ,seven)) 0)) | |
| 572 | |
| 573 (Assert (eq (mod 0 ,seven) 0)) | |
| 574 (Assert (eq (mod 0 (- ,seven)) 0)) | |
| 575 | |
| 576 (Assert (= (mod 0.0 ,seven) 0.0)) | |
| 577 (Assert (= (mod 0.0 (- ,seven)) 0.0))))) | |
| 578 | |
| 579 (division-test 7) | |
| 580 (division-test ?\07) | |
| 581 (division-test (Int-to-Marker 7))) | |
| 582 | |
| 1983 | 583 (when (featurep 'bignum) |
| 584 (let ((big (+ (* 7 most-positive-fixnum 6))) | |
| 585 (negbig (- (* 7 most-negative-fixnum 6)))) | |
| 586 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum) | |
| 587 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum) | |
| 588 (= (mod big (1+ most-positive-fixnum)) most-positive-fixnum) | |
| 589 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum))) | |
| 428 | 590 |
| 591 ;;----------------------------------------------------- | |
| 592 ;; Arithmetic comparison operations | |
| 593 ;;----------------------------------------------------- | |
| 594 (Check-Error wrong-number-of-arguments (=)) | |
| 595 (Check-Error wrong-number-of-arguments (<)) | |
| 596 (Check-Error wrong-number-of-arguments (>)) | |
| 597 (Check-Error wrong-number-of-arguments (<=)) | |
| 598 (Check-Error wrong-number-of-arguments (>=)) | |
| 599 (Check-Error wrong-number-of-arguments (/=)) | |
| 600 | |
| 601 ;; One argument always yields t | |
| 602 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do | |
| 2056 | 603 (Assert (eq t (= x)) x) |
| 604 (Assert (eq t (< x)) x) | |
| 605 (Assert (eq t (> x)) x) | |
| 606 (Assert (eq t (>= x)) x) | |
| 607 (Assert (eq t (<= x)) x) | |
| 608 (Assert (eq t (/= x)) x) | |
| 428 | 609 ) |
| 610 | |
| 611 ;; Type checking | |
| 612 (Check-Error wrong-type-argument (= 'foo 1)) | |
| 613 (Check-Error wrong-type-argument (<= 'foo 1)) | |
| 614 (Check-Error wrong-type-argument (>= 'foo 1)) | |
| 615 (Check-Error wrong-type-argument (< 'foo 1)) | |
| 616 (Check-Error wrong-type-argument (> 'foo 1)) | |
| 617 (Check-Error wrong-type-argument (/= 'foo 1)) | |
| 618 | |
| 619 ;; Meat | |
| 620 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
| 621 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 622 (Assert (< one two) (list one two)) |
| 623 (Assert (<= one two) (list one two)) | |
| 624 (Assert (<= two two) two) | |
| 625 (Assert (> two one) (list one two)) | |
| 626 (Assert (>= two one) (list one two)) | |
| 627 (Assert (>= two two) two) | |
| 628 (Assert (/= one two) (list one two)) | |
| 629 (Assert (not (/= two two)) two) | |
| 630 (Assert (not (< one one)) one) | |
| 631 (Assert (not (> one one)) one) | |
| 632 (Assert (<= one one two two) (list one two)) | |
| 633 (Assert (not (< one one two two)) (list one two)) | |
| 634 (Assert (>= two two one one) (list one two)) | |
| 635 (Assert (not (> two two one one)) (list one two)) | |
| 636 (Assert (= one one one) one) | |
| 637 (Assert (not (= one one one two)) (list one two)) | |
| 638 (Assert (not (/= one two one)) (list one two)) | |
| 428 | 639 )) |
| 640 | |
| 641 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
| 642 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 643 (Assert (< one two) (list one two)) |
| 644 (Assert (<= one two) (list one two)) | |
| 645 (Assert (<= two two) two) | |
| 646 (Assert (> two one) (list one two)) | |
| 647 (Assert (>= two one) (list one two)) | |
| 648 (Assert (>= two two) two) | |
| 649 (Assert (/= one two) (list one two)) | |
| 650 (Assert (not (/= two two)) two) | |
| 651 (Assert (not (< one one)) one) | |
| 652 (Assert (not (> one one)) one) | |
| 653 (Assert (<= one one two two) (list one two)) | |
| 654 (Assert (not (< one one two two)) (list one two)) | |
| 655 (Assert (>= two two one one) (list one two)) | |
| 656 (Assert (not (> two two one one)) (list one two)) | |
| 657 (Assert (= one one one) one) | |
| 658 (Assert (not (= one one one two)) (list one two)) | |
| 659 (Assert (not (/= one two one)) (list one two)) | |
| 428 | 660 )) |
| 661 | |
| 662 ;; ad-hoc | |
| 663 (Assert (< 1 2)) | |
| 664 (Assert (< 1 2 3 4 5 6)) | |
| 665 (Assert (not (< 1 1))) | |
| 666 (Assert (not (< 2 1))) | |
| 667 | |
| 668 | |
| 669 (Assert (not (< 1 1))) | |
| 670 (Assert (< 1 2 3 4 5 6)) | |
| 671 (Assert (<= 1 2 3 4 5 6)) | |
| 672 (Assert (<= 1 2 3 4 5 6 6)) | |
| 673 (Assert (not (< 1 2 3 4 5 6 6))) | |
| 674 (Assert (<= 1 1)) | |
| 675 | |
| 676 (Assert (not (eq (point) (point-marker)))) | |
| 677 (Assert (= 1 (Int-to-Marker 1))) | |
| 678 (Assert (= (point) (point-marker))) | |
| 679 | |
| 1983 | 680 (when (featurep 'bignum) |
| 681 (let ((big1 (1+ most-positive-fixnum)) | |
| 682 (big2 (* 10 most-positive-fixnum)) | |
| 683 (small1 (1- most-negative-fixnum)) | |
| 684 (small2 (* 10 most-negative-fixnum))) | |
| 685 (Assert (< small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 686 big2)) | |
| 687 (Assert (<= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 688 big2)) | |
| 689 (Assert (> big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 690 small2)) | |
| 691 (Assert (>= big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 692 small2)) | |
| 693 (Assert (/= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 694 big2)))) | |
| 695 | |
| 696 (when (featurep 'ratio) | |
| 697 (let ((big1 (div (* 10 most-positive-fixnum) 4)) | |
| 698 (big2 (div (* 5 most-positive-fixnum) 2)) | |
| 699 (big3 (div (* 7 most-positive-fixnum) 2)) | |
| 700 (small1 (div (* 10 most-negative-fixnum) 4)) | |
| 701 (small2 (div (* 5 most-negative-fixnum) 2)) | |
| 702 (small3 (div (* 7 most-negative-fixnum) 2))) | |
| 703 (Assert (= big1 big2)) | |
| 704 (Assert (= small1 small2)) | |
| 705 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 706 big3)) | |
| 707 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum | |
| 708 big1 big2 big3)) | |
| 709 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 710 small3)) | |
| 711 (Assert (>= big3 big2 big1 most-positive-fixnum most-negative-fixnum | |
| 712 small1 small2 small3)) | |
| 713 (Assert (/= big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 714 small3)))) | |
| 715 | |
| 428 | 716 ;;----------------------------------------------------- |
| 717 ;; testing list-walker functions | |
| 718 ;;----------------------------------------------------- | |
| 719 (macrolet | |
| 720 ((test-fun | |
| 721 (fun) | |
| 722 `(progn | |
| 723 (Check-Error wrong-number-of-arguments (,fun)) | |
| 724 (Check-Error wrong-number-of-arguments (,fun nil)) | |
| 725 (Check-Error malformed-list (,fun nil 1)) | |
| 726 ,@(loop for n in '(1 2 2000) | |
| 727 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) | |
| 728 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))) | |
| 729 | |
| 730 (test-funs member old-member | |
| 731 memq old-memq | |
| 732 assoc old-assoc | |
| 733 rassoc old-rassoc | |
| 734 rassq old-rassq | |
| 735 delete old-delete | |
| 736 delq old-delq | |
| 737 remassoc remassq remrassoc remrassq)) | |
| 738 | |
| 739 (let ((x '((1 . 2) 3 (4 . 5)))) | |
| 740 (Assert (eq (assoc 1 x) (car x))) | |
| 741 (Assert (eq (assq 1 x) (car x))) | |
| 742 (Assert (eq (rassoc 1 x) nil)) | |
| 743 (Assert (eq (rassq 1 x) nil)) | |
| 744 (Assert (eq (assoc 2 x) nil)) | |
| 745 (Assert (eq (assq 2 x) nil)) | |
| 746 (Assert (eq (rassoc 2 x) (car x))) | |
| 747 (Assert (eq (rassq 2 x) (car x))) | |
| 748 (Assert (eq (assoc 3 x) nil)) | |
| 749 (Assert (eq (assq 3 x) nil)) | |
| 750 (Assert (eq (rassoc 3 x) nil)) | |
| 751 (Assert (eq (rassq 3 x) nil)) | |
| 752 (Assert (eq (assoc 4 x) (caddr x))) | |
| 753 (Assert (eq (assq 4 x) (caddr x))) | |
| 754 (Assert (eq (rassoc 4 x) nil)) | |
| 755 (Assert (eq (rassq 4 x) nil)) | |
| 756 (Assert (eq (assoc 5 x) nil)) | |
| 757 (Assert (eq (assq 5 x) nil)) | |
| 758 (Assert (eq (rassoc 5 x) (caddr x))) | |
| 759 (Assert (eq (rassq 5 x) (caddr x))) | |
| 760 (Assert (eq (assoc 6 x) nil)) | |
| 761 (Assert (eq (assq 6 x) nil)) | |
| 762 (Assert (eq (rassoc 6 x) nil)) | |
| 763 (Assert (eq (rassq 6 x) nil))) | |
| 764 | |
| 765 (let ((x '(("1" . "2") "3" ("4" . "5")))) | |
| 766 (Assert (eq (assoc "1" x) (car x))) | |
| 767 (Assert (eq (assq "1" x) nil)) | |
| 768 (Assert (eq (rassoc "1" x) nil)) | |
| 769 (Assert (eq (rassq "1" x) nil)) | |
| 770 (Assert (eq (assoc "2" x) nil)) | |
| 771 (Assert (eq (assq "2" x) nil)) | |
| 772 (Assert (eq (rassoc "2" x) (car x))) | |
| 773 (Assert (eq (rassq "2" x) nil)) | |
| 774 (Assert (eq (assoc "3" x) nil)) | |
| 775 (Assert (eq (assq "3" x) nil)) | |
| 776 (Assert (eq (rassoc "3" x) nil)) | |
| 777 (Assert (eq (rassq "3" x) nil)) | |
| 778 (Assert (eq (assoc "4" x) (caddr x))) | |
| 779 (Assert (eq (assq "4" x) nil)) | |
| 780 (Assert (eq (rassoc "4" x) nil)) | |
| 781 (Assert (eq (rassq "4" x) nil)) | |
| 782 (Assert (eq (assoc "5" x) nil)) | |
| 783 (Assert (eq (assq "5" x) nil)) | |
| 784 (Assert (eq (rassoc "5" x) (caddr x))) | |
| 785 (Assert (eq (rassq "5" x) nil)) | |
| 786 (Assert (eq (assoc "6" x) nil)) | |
| 787 (Assert (eq (assq "6" x) nil)) | |
| 788 (Assert (eq (rassoc "6" x) nil)) | |
| 789 (Assert (eq (rassq "6" x) nil))) | |
| 790 | |
| 791 (flet ((a () (list '(1 . 2) 3 '(4 . 5)))) | |
| 792 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 793 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 794 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a))))) | |
| 795 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a))))) | |
| 796 | |
| 797 (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a))))) | |
| 798 (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a))))) | |
| 799 (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 800 (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 801 | |
| 802 (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a))))) | |
| 803 (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a))))) | |
| 804 (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a))))) | |
| 805 (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a))))) | |
| 806 | |
| 807 (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 808 (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 809 (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a))))) | |
| 810 (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a))))) | |
| 811 | |
| 812 (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a))))) | |
| 813 (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a))))) | |
| 814 (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 815 (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 816 | |
| 817 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a))))) | |
| 818 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a))))) | |
| 819 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a))))) | |
| 820 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a))))) | |
| 821 | |
| 822 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 823 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 824 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 825 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 826 | |
| 827 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 828 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) | |
| 829 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 830 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) | |
| 831 ) | |
| 832 | |
| 833 | |
| 834 | |
| 835 (flet ((a () (list '("1" . "2") "3" '("4" . "5")))) | |
| 836 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) | |
| 837 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a))))) | |
| 838 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a))))) | |
| 839 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a))))) | |
| 840 | |
| 841 (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a))))) | |
| 842 (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a))))) | |
| 843 (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) | |
| 844 (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a))))) | |
| 845 | |
| 846 (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a))))) | |
| 847 (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a))))) | |
| 848 (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a))))) | |
| 849 (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a))))) | |
| 850 | |
| 851 (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
| 852 (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a))))) | |
| 853 (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a))))) | |
| 854 (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a))))) | |
| 855 | |
| 856 (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a))))) | |
| 857 (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a))))) | |
| 858 (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
| 859 (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a))))) | |
| 860 | |
| 861 (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a))))) | |
| 862 (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a))))) | |
| 863 (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a))))) | |
| 864 (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a)))))) | |
| 865 | |
| 866 ;;----------------------------------------------------- | |
| 867 ;; function-max-args, function-min-args | |
| 868 ;;----------------------------------------------------- | |
| 869 (defmacro check-function-argcounts (fun min max) | |
| 870 `(progn | |
| 871 (Assert (eq (function-min-args ,fun) ,min)) | |
| 872 (Assert (eq (function-max-args ,fun) ,max)))) | |
| 873 | |
| 874 (check-function-argcounts 'prog1 1 nil) ; special form | |
| 875 (check-function-argcounts 'command-execute 1 3) ; normal subr | |
| 876 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr | |
| 877 (check-function-argcounts 'garbage-collect 0 0) ; no args subr | |
| 878 | |
| 879 ;; Test interpreted and compiled functions | |
| 880 (loop for (arglist min max) in | |
| 881 '(((arg1 arg2 &rest args) 2 nil) | |
| 882 ((arg1 arg2 &optional arg3 arg4) 2 4) | |
| 883 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil) | |
| 884 (() 0 0)) | |
| 885 do | |
| 886 (eval | |
| 887 `(progn | |
| 888 (defun test-fun ,arglist nil) | |
| 889 (check-function-argcounts '(lambda ,arglist nil) ,min ,max) | |
| 890 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max)))) | |
| 891 | |
|
4575
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
892 ;; Test subr-arity. |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
893 (loop for (function-name arity) in |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
894 '((let (1 . unevalled)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
895 (prog1 (1 . unevalled)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
896 (list (0 . many)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
897 (type-of (1 . 1)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
898 (garbage-collect (0 . 0))) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
899 do (Assert (equal (subr-arity (symbol-function function-name)) arity))) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
900 |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
901 (Check-Error wrong-type-argument (subr-arity |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
902 (lambda () (message "Hi there!")))) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
903 |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
904 (Check-Error wrong-type-argument (subr-arity nil)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
905 |
| 428 | 906 ;;----------------------------------------------------- |
| 907 ;; Detection of cyclic variable indirection loops | |
| 908 ;;----------------------------------------------------- | |
| 909 (fset 'test-sym1 'test-sym1) | |
| 910 (Check-Error cyclic-function-indirection (test-sym1)) | |
| 911 | |
| 912 (fset 'test-sym1 'test-sym2) | |
| 913 (fset 'test-sym2 'test-sym1) | |
| 914 (Check-Error cyclic-function-indirection (test-sym1)) | |
| 915 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops! | |
| 916 (fmakunbound 'test-sym2) | |
| 917 | |
| 918 ;;----------------------------------------------------- | |
| 919 ;; Test `type-of' | |
| 920 ;;----------------------------------------------------- | |
| 921 (Assert (eq (type-of load-path) 'cons)) | |
| 922 (Assert (eq (type-of obarray) 'vector)) | |
| 923 (Assert (eq (type-of 42) 'integer)) | |
| 924 (Assert (eq (type-of ?z) 'character)) | |
| 925 (Assert (eq (type-of "42") 'string)) | |
| 926 (Assert (eq (type-of 'foo) 'symbol)) | |
| 927 (Assert (eq (type-of (selected-device)) 'device)) | |
| 928 | |
| 929 ;;----------------------------------------------------- | |
| 930 ;; Test mapping functions | |
| 931 ;;----------------------------------------------------- | |
| 932 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer))) | |
| 933 (Assert (equal (mapcar #'identity load-path) load-path)) | |
| 934 (Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3))) | |
| 935 (Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3))) | |
| 936 (Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3))) | |
| 937 (Assert (equal (mapcar #'identity #*010) '(0 1 0))) | |
| 938 | |
| 939 (let ((z 0) (list (make-list 1000 1))) | |
| 940 (mapc (lambda (x) (incf z x)) list) | |
| 941 (Assert (eq 1000 z))) | |
| 942 | |
| 943 (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 "123") [?1 ?2 ?3])) | |
| 946 (Assert (equal (mapvector #'identity [1 2 3]) [1 2 3])) | |
| 947 (Assert (equal (mapvector #'identity #*010) [0 1 0])) | |
| 948 | |
| 949 (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")) | |
| 952 | |
| 434 | 953 ;; The following 2 functions used to crash XEmacs via mapcar1(). |
| 954 ;; We don't test the actual values of the mapcar, since they're undefined. | |
| 446 | 955 (Assert |
| 434 | 956 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
| 957 (mapcar | |
| 958 (lambda (y) | |
| 959 "Devious evil mapping function" | |
| 960 (when (eq (car y) 2) ; go out onto a limb | |
| 961 (setcdr x nil) ; cut it off behind us | |
| 962 (garbage-collect)) ; are we riding a magic broomstick? | |
| 963 (car y)) ; sorry, hard landing | |
| 964 x))) | |
| 965 | |
| 446 | 966 (Assert |
| 434 | 967 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
| 968 (mapcar | |
| 969 (lambda (y) | |
| 970 "Devious evil mapping function" | |
| 971 (when (eq (car y) 1) | |
| 972 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway | |
| 973 (car y)) | |
| 974 x))) | |
| 975 | |
| 428 | 976 ;;----------------------------------------------------- |
| 977 ;; Test vector functions | |
| 978 ;;----------------------------------------------------- | |
| 979 (Assert (equal [1 2 3] [1 2 3])) | |
| 980 (Assert (equal [] [])) | |
| 981 (Assert (not (equal [1 2 3] []))) | |
| 982 (Assert (not (equal [1 2 3] [1 2 4]))) | |
| 983 (Assert (not (equal [0 2 3] [1 2 3]))) | |
| 984 (Assert (not (equal [1 2 3] [1 2 3 4]))) | |
| 985 (Assert (not (equal [1 2 3 4] [1 2 3]))) | |
| 986 (Assert (equal (vector 1 2 3) [1 2 3])) | |
| 987 (Assert (equal (make-vector 3 1) [1 1 1])) | |
| 988 | |
| 989 ;;----------------------------------------------------- | |
| 990 ;; Test bit-vector functions | |
| 991 ;;----------------------------------------------------- | |
| 992 (Assert (equal #*010 #*010)) | |
| 993 (Assert (equal #* #*)) | |
| 994 (Assert (not (equal #*010 #*011))) | |
| 995 (Assert (not (equal #*010 #*))) | |
| 996 (Assert (not (equal #*110 #*010))) | |
| 997 (Assert (not (equal #*010 #*0100))) | |
| 998 (Assert (not (equal #*0101 #*010))) | |
| 999 (Assert (equal (bit-vector 0 1 0) #*010)) | |
| 1000 (Assert (equal (make-bit-vector 3 1) #*111)) | |
| 1001 (Assert (equal (make-bit-vector 3 0) #*000)) | |
| 1002 | |
| 1003 ;;----------------------------------------------------- | |
| 1004 ;; Test buffer-local variables used as (ugh!) function parameters | |
| 1005 ;;----------------------------------------------------- | |
| 1006 (make-local-variable 'test-emacs-buffer-local-variable) | |
| 1007 (byte-compile | |
| 1008 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable) | |
| 1009 (setq test-emacs-buffer-local-variable nil))) | |
| 1010 (test-emacs-buffer-local-parameter nil) | |
| 1011 | |
| 1012 ;;----------------------------------------------------- | |
| 1013 ;; Test split-string | |
| 1014 ;;----------------------------------------------------- | |
| 1425 | 1015 ;; Keep nulls, explicit SEPARATORS |
| 1016 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb | |
| 1017 ;; I assume Hrvoje worried about the possibility of infloops. -sjt | |
| 1018 (when test-harness-risk-infloops | |
| 1019 (Assert (equal (split-string "foo" "") '("" "f" "o" "o" ""))) | |
| 1020 (Assert (equal (split-string "foo" "^") '("" "foo"))) | |
| 1021 (Assert (equal (split-string "foo" "$") '("foo" "")))) | |
| 428 | 1022 (Assert (equal (split-string "foo,bar" ",") '("foo" "bar"))) |
| 1023 (Assert (equal (split-string ",foo,bar," ",") '("" "foo" "bar" ""))) | |
| 1024 (Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,"))) | |
| 1025 (Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" ""))) | |
| 1026 (Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" ""))) | |
| 1027 (Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar"))) | |
| 1028 (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" ""))) | |
| 1425 | 1031 ;; Omit nulls, explicit SEPARATORS |
| 1032 (when test-harness-risk-infloops | |
| 1033 (Assert (equal (split-string "foo" "" t) '("f" "o" "o"))) | |
| 1034 (Assert (equal (split-string "foo" "^" t) '("foo"))) | |
| 1035 (Assert (equal (split-string "foo" "$" t) '("foo")))) | |
| 1036 (Assert (equal (split-string "foo,bar" "," t) '("foo" "bar"))) | |
| 1037 (Assert (equal (split-string ",foo,bar," "," t) '("foo" "bar"))) | |
| 1038 (Assert (equal (split-string ",foo,bar," "^," t) '("foo,bar,"))) | |
| 1039 (Assert (equal (split-string ",foo,bar," ",$" t) '(",foo,bar"))) | |
| 1040 (Assert (equal (split-string ",foo,,bar," "," t) '("foo" "bar"))) | |
| 1041 (Assert (equal (split-string "foo,,,bar" "," t) '("foo" "bar"))) | |
| 1042 (Assert (equal (split-string "foo,,bar,," "," t) '("foo" "bar"))) | |
| 1043 (Assert (equal (split-string "foo,,bar" ",+" t) '("foo" "bar"))) | |
| 1044 (Assert (equal (split-string ",foo,,bar," ",+" t) '("foo" "bar"))) | |
| 1045 ;; "Double-default" case | |
| 1046 (Assert (equal (split-string "foo bar") '("foo" "bar"))) | |
| 1047 (Assert (equal (split-string " foo bar ") '("foo" "bar"))) | |
| 1048 (Assert (equal (split-string " foo bar ") '("foo" "bar"))) | |
| 1049 (Assert (equal (split-string "foo bar") '("foo" "bar"))) | |
| 1050 (Assert (equal (split-string "foo bar ") '("foo" "bar"))) | |
| 1051 (Assert (equal (split-string "foobar") '("foobar"))) | |
| 1052 ;; Semantics are identical to "double-default" case! Fool ya? | |
| 1053 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) | |
| 1054 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) | |
| 1055 (Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) | |
| 1056 (Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) | |
| 1057 (Assert (equal (split-string "foo bar " nil t) '("foo" "bar"))) | |
| 1058 (Assert (equal (split-string "foobar" nil t) '("foobar"))) | |
| 1059 ;; Perverse "anti-double-default" case | |
| 1060 (Assert (equal (split-string "foo bar" split-string-default-separators) | |
| 1061 '("foo" "bar"))) | |
| 1062 (Assert (equal (split-string " foo bar " split-string-default-separators) | |
| 1063 '("" "foo" "bar" ""))) | |
| 1064 (Assert (equal (split-string " foo bar " split-string-default-separators) | |
| 1065 '("" "foo" "bar" ""))) | |
| 1066 (Assert (equal (split-string "foo bar" split-string-default-separators) | |
| 1067 '("foo" "bar"))) | |
| 1068 (Assert (equal (split-string "foo bar " split-string-default-separators) | |
| 1069 '("foo" "bar" ""))) | |
| 1070 (Assert (equal (split-string "foobar" split-string-default-separators) | |
| 1071 '("foobar"))) | |
| 434 | 1072 |
| 442 | 1073 (Assert (not (string-match "\\(\\.\\=\\)" "."))) |
| 446 | 1074 (Assert (string= "" (let ((str "test string")) |
| 444 | 1075 (if (string-match "^.*$" str) |
| 1076 (replace-match "\\U" t nil str))))) | |
| 1077 (with-temp-buffer | |
| 1078 (erase-buffer) | |
| 1079 (insert "test string") | |
| 1080 (re-search-backward "^.*$") | |
| 1081 (replace-match "\\U" t) | |
| 1082 (Assert (and (bobp) (eobp)))) | |
| 442 | 1083 |
| 434 | 1084 ;;----------------------------------------------------- |
| 1085 ;; Test near-text buffer functions. | |
| 1086 ;;----------------------------------------------------- | |
| 1087 (with-temp-buffer | |
| 1088 (erase-buffer) | |
| 1089 (Assert (eq (char-before) nil)) | |
| 1090 (Assert (eq (char-before (point)) nil)) | |
| 1091 (Assert (eq (char-before (point-marker)) nil)) | |
| 1092 (Assert (eq (char-before (point) (current-buffer)) nil)) | |
| 1093 (Assert (eq (char-before (point-marker) (current-buffer)) nil)) | |
| 1094 (Assert (eq (char-after) nil)) | |
| 1095 (Assert (eq (char-after (point)) nil)) | |
| 1096 (Assert (eq (char-after (point-marker)) nil)) | |
| 1097 (Assert (eq (char-after (point) (current-buffer)) nil)) | |
| 1098 (Assert (eq (char-after (point-marker) (current-buffer)) nil)) | |
| 1099 (Assert (eq (preceding-char) 0)) | |
| 1100 (Assert (eq (preceding-char (current-buffer)) 0)) | |
| 1101 (Assert (eq (following-char) 0)) | |
| 1102 (Assert (eq (following-char (current-buffer)) 0)) | |
| 1103 (insert "foobar") | |
| 1104 (Assert (eq (char-before) ?r)) | |
| 1105 (Assert (eq (char-after) nil)) | |
| 1106 (Assert (eq (preceding-char) ?r)) | |
| 1107 (Assert (eq (following-char) 0)) | |
| 1108 (goto-char (point-min)) | |
| 1109 (Assert (eq (char-before) nil)) | |
| 1110 (Assert (eq (char-after) ?f)) | |
| 1111 (Assert (eq (preceding-char) 0)) | |
| 1112 (Assert (eq (following-char) ?f)) | |
| 1113 ) | |
| 440 | 1114 |
| 1115 ;;----------------------------------------------------- | |
| 1116 ;; Test plist manipulation functions. | |
| 1117 ;;----------------------------------------------------- | |
| 1118 (let ((sym (make-symbol "test-symbol"))) | |
| 1119 (Assert (eq t (get* sym t t))) | |
| 1120 (Assert (eq t (get sym t t))) | |
| 1121 (Assert (eq t (getf nil t t))) | |
| 1122 (Assert (eq t (plist-get nil t t))) | |
| 1123 (put sym 'bar 'baz) | |
| 1124 (Assert (eq 'baz (get sym 'bar))) | |
| 1125 (Assert (eq 'baz (getf '(bar baz) 'bar))) | |
| 1126 (Assert (eq 'baz (getf (symbol-plist sym) 'bar))) | |
| 1127 (Assert (eq 2 (getf '(1 2) 1))) | |
| 442 | 1128 (Assert (eq 4 (put sym 3 4))) |
| 1129 (Assert (eq 4 (get sym 3))) | |
| 1130 (Assert (eq t (remprop sym 3))) | |
| 1131 (Assert (eq nil (remprop sym 3))) | |
| 1132 (Assert (eq 5 (get sym 3 5))) | |
| 440 | 1133 ) |
| 442 | 1134 |
| 1135 (loop for obj in | |
| 1136 (list (make-symbol "test-symbol") | |
| 1137 "test-string" | |
| 1138 (make-extent nil nil nil) | |
| 1139 (make-face 'test-face)) | |
| 1140 do | |
| 2056 | 1141 (Assert (eq 2 (get obj ?1 2)) obj) |
| 1142 (Assert (eq 4 (put obj ?3 4)) obj) | |
| 1143 (Assert (eq 4 (get obj ?3)) obj) | |
| 442 | 1144 (when (or (stringp obj) (symbolp obj)) |
| 2056 | 1145 (Assert (equal '(?3 4) (object-plist obj)) obj)) |
| 1146 (Assert (eq t (remprop obj ?3)) obj) | |
| 442 | 1147 (when (or (stringp obj) (symbolp obj)) |
| 2056 | 1148 (Assert (eq '() (object-plist obj)) obj)) |
| 1149 (Assert (eq nil (remprop obj ?3)) obj) | |
| 442 | 1150 (when (or (stringp obj) (symbolp obj)) |
| 2056 | 1151 (Assert (eq '() (object-plist obj)) obj)) |
| 1152 (Assert (eq 5 (get obj ?3 5)) obj) | |
| 442 | 1153 ) |
| 1154 | |
| 1155 (Check-Error-Message | |
| 1156 error "Object type has no properties" | |
| 1157 (get 2 'property)) | |
| 1158 | |
| 1159 (Check-Error-Message | |
| 1160 error "Object type has no settable properties" | |
| 1161 (put (current-buffer) 'property 'value)) | |
| 1162 | |
| 1163 (Check-Error-Message | |
| 1164 error "Object type has no removable properties" | |
| 1165 (remprop ?3 'property)) | |
| 1166 | |
| 1167 (Check-Error-Message | |
| 1168 error "Object type has no properties" | |
| 1169 (object-plist (symbol-function 'car))) | |
| 1170 | |
| 1171 (Check-Error-Message | |
| 1172 error "Can't remove property from object" | |
| 1173 (remprop (make-extent nil nil nil) 'detachable)) | |
| 1174 | |
| 1175 ;;----------------------------------------------------- | |
| 1176 ;; Test subseq | |
| 1177 ;;----------------------------------------------------- | |
| 1178 (Assert (equal (subseq nil 0) nil)) | |
| 1179 (Assert (equal (subseq [1 2 3] 0) [1 2 3])) | |
| 1180 (Assert (equal (subseq [1 2 3] 1 -1) [2])) | |
| 1181 (Assert (equal (subseq "123" 0) "123")) | |
| 1182 (Assert (equal (subseq "1234" -3 -1) "23")) | |
| 1183 (Assert (equal (subseq #*0011 0) #*0011)) | |
| 1184 (Assert (equal (subseq #*0011 -3 3) #*01)) | |
| 1185 (Assert (equal (subseq '(1 2 3) 0) '(1 2 3))) | |
| 1186 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4))) | |
| 1187 | |
| 446 | 1188 (Check-Error wrong-type-argument (subseq 3 2)) |
| 1189 (Check-Error args-out-of-range (subseq [1 2 3] -42)) | |
| 1190 (Check-Error args-out-of-range (subseq [1 2 3] 0 42)) | |
| 442 | 1191 |
| 1192 ;;----------------------------------------------------- | |
| 1193 ;; Time-related tests | |
| 1194 ;;----------------------------------------------------- | |
| 1195 (Assert (= (length (current-time-string)) 24)) | |
| 444 | 1196 |
| 1197 ;;----------------------------------------------------- | |
| 1198 ;; format test | |
| 1199 ;;----------------------------------------------------- | |
| 1200 (Assert (string= (format "%d" 10) "10")) | |
| 1201 (Assert (string= (format "%o" 8) "10")) | |
| 1202 (Assert (string= (format "%x" 31) "1f")) | |
| 1203 (Assert (string= (format "%X" 31) "1F")) | |
| 826 | 1204 ;; MS-Windows uses +002 in its floating-point numbers. #### We should |
| 1205 ;; perhaps fix this, but writing our own floating-point support in doprnt.c | |
| 1206 ;; is very hard. | |
| 1207 (Assert (or (string= (format "%e" 100) "1.000000e+02") | |
| 1208 (string= (format "%e" 100) "1.000000e+002"))) | |
| 1209 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
| 1210 (string= (format "%E" 100) "1.000000E+002"))) | |
| 1211 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
| 1212 (string= (format "%E" 100) "1.000000E+002"))) | |
| 444 | 1213 (Assert (string= (format "%f" 100) "100.000000")) |
| 448 | 1214 (Assert (string= (format "%7.3f" 12.12345) " 12.123")) |
| 1215 (Assert (string= (format "%07.3f" 12.12345) "012.123")) | |
| 1216 (Assert (string= (format "%-7.3f" 12.12345) "12.123 ")) | |
| 1217 (Assert (string= (format "%-07.3f" 12.12345) "12.123 ")) | |
| 444 | 1218 (Assert (string= (format "%g" 100.0) "100")) |
| 826 | 1219 (Assert (or (string= (format "%g" 0.000001) "1e-06") |
| 1220 (string= (format "%g" 0.000001) "1e-006"))) | |
| 444 | 1221 (Assert (string= (format "%g" 0.0001) "0.0001")) |
| 1222 (Assert (string= (format "%G" 100.0) "100")) | |
| 826 | 1223 (Assert (or (string= (format "%G" 0.000001) "1E-06") |
| 1224 (string= (format "%G" 0.000001) "1E-006"))) | |
| 444 | 1225 (Assert (string= (format "%G" 0.0001) "0.0001")) |
| 1226 | |
| 1227 (Assert (string= (format "%2$d%1$d" 10 20) "2010")) | |
| 1228 (Assert (string= (format "%-d" 10) "10")) | |
| 1229 (Assert (string= (format "%-4d" 10) "10 ")) | |
| 1230 (Assert (string= (format "%+d" 10) "+10")) | |
| 1231 (Assert (string= (format "%+d" -10) "-10")) | |
| 1232 (Assert (string= (format "%+4d" 10) " +10")) | |
| 1233 (Assert (string= (format "%+4d" -10) " -10")) | |
| 1234 (Assert (string= (format "% d" 10) " 10")) | |
| 1235 (Assert (string= (format "% d" -10) "-10")) | |
| 1236 (Assert (string= (format "% 4d" 10) " 10")) | |
| 1237 (Assert (string= (format "% 4d" -10) " -10")) | |
| 1238 (Assert (string= (format "%0d" 10) "10")) | |
| 1239 (Assert (string= (format "%0d" -10) "-10")) | |
| 1240 (Assert (string= (format "%04d" 10) "0010")) | |
| 1241 (Assert (string= (format "%04d" -10) "-010")) | |
| 1242 (Assert (string= (format "%*d" 4 10) " 10")) | |
| 1243 (Assert (string= (format "%*d" 4 -10) " -10")) | |
| 1244 (Assert (string= (format "%*d" -4 10) "10 ")) | |
| 1245 (Assert (string= (format "%*d" -4 -10) "-10 ")) | |
| 1246 (Assert (string= (format "%#d" 10) "10")) | |
| 1247 (Assert (string= (format "%#o" 8) "010")) | |
| 1248 (Assert (string= (format "%#x" 16) "0x10")) | |
| 826 | 1249 (Assert (or (string= (format "%#e" 100) "1.000000e+02") |
| 1250 (string= (format "%#e" 100) "1.000000e+002"))) | |
| 1251 (Assert (or (string= (format "%#E" 100) "1.000000E+02") | |
| 1252 (string= (format "%#E" 100) "1.000000E+002"))) | |
| 444 | 1253 (Assert (string= (format "%#f" 100) "100.000000")) |
| 1254 (Assert (string= (format "%#g" 100.0) "100.000")) | |
| 826 | 1255 (Assert (or (string= (format "%#g" 0.000001) "1.00000e-06") |
| 1256 (string= (format "%#g" 0.000001) "1.00000e-006"))) | |
| 444 | 1257 (Assert (string= (format "%#g" 0.0001) "0.000100000")) |
| 1258 (Assert (string= (format "%#G" 100.0) "100.000")) | |
| 826 | 1259 (Assert (or (string= (format "%#G" 0.000001) "1.00000E-06") |
| 1260 (string= (format "%#G" 0.000001) "1.00000E-006"))) | |
| 444 | 1261 (Assert (string= (format "%#G" 0.0001) "0.000100000")) |
| 1262 (Assert (string= (format "%.1d" 10) "10")) | |
| 1263 (Assert (string= (format "%.4d" 10) "0010")) | |
| 1264 ;; Combination of `-', `+', ` ', `0', `#', `.', `*' | |
| 448 | 1265 (Assert (string= (format "%-04d" 10) "10 ")) |
| 444 | 1266 (Assert (string= (format "%-*d" 4 10) "10 ")) |
| 1267 ;; #### Correctness of this behavior is questionable. | |
| 1268 ;; It might be better to signal error. | |
| 1269 (Assert (string= (format "%-*d" -4 10) "10 ")) | |
| 1270 ;; These behavior is not specified. | |
| 1271 ;; (format "%-+d" 10) | |
| 1272 ;; (format "%- d" 10) | |
| 1273 ;; (format "%-01d" 10) | |
| 1274 ;; (format "%-#4x" 10) | |
| 1275 ;; (format "%-.1d" 10) | |
| 1276 | |
| 1277 (Assert (string= (format "%01.1d" 10) "10")) | |
| 448 | 1278 (Assert (string= (format "%03.1d" 10) " 10")) |
| 1279 (Assert (string= (format "%01.3d" 10) "010")) | |
| 1280 (Assert (string= (format "%1.3d" 10) "010")) | |
| 444 | 1281 (Assert (string= (format "%3.1d" 10) " 10")) |
| 446 | 1282 |
| 448 | 1283 ;;; The following two tests used to use 1000 instead of 100, |
| 1284 ;;; but that merely found buffer overflow bugs in Solaris sprintf(). | |
| 1285 (Assert (= 102 (length (format "%.100f" 3.14)))) | |
| 1286 (Assert (= 100 (length (format "%100f" 3.14)))) | |
| 1287 | |
| 446 | 1288 ;;; Check for 64-bit cleanness on LP64 platforms. |
| 1289 (Assert (= (read (format "%d" most-positive-fixnum)) most-positive-fixnum)) | |
| 1290 (Assert (= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum)) | |
| 1291 (Assert (= (read (format "%u" most-positive-fixnum)) most-positive-fixnum)) | |
| 1292 (Assert (= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum)) | |
| 1293 (Assert (= (read (format "%d" most-negative-fixnum)) most-negative-fixnum)) | |
| 1294 (Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum)) | |
| 1295 | |
| 4287 | 1296 ;; These used to crash. |
| 1297 (Assert (eql (read (format "%f" 1.2e+302)) 1.2e+302)) | |
| 1298 (Assert (eql (read (format "%.1000d" 1)) 1)) | |
| 1299 | |
| 446 | 1300 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. |
| 1301 ;;; What to do if "%u" is used with a negative number? | |
| 1983 | 1302 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an |
| 1303 ;;; un-read-able number. The printed value might be useful to a human, if not | |
| 1304 ;;; to Emacs Lisp. | |
| 1305 ;;; For bignum XEmacsen, we make %u with a negative value throw an error. | |
| 1306 (if (featurep 'bignum) | |
| 1307 (progn | |
| 1308 (Check-Error wrong-type-argument (format "%u" most-negative-fixnum)) | |
| 1309 (Check-Error wrong-type-argument (format "%u" -1))) | |
| 1310 (Check-Error invalid-read-syntax (read (format "%u" most-negative-fixnum))) | |
| 1311 (Check-Error invalid-read-syntax (read (format "%u" -1)))) | |
| 448 | 1312 |
| 1313 ;; Check all-completions ignore element start with space. | |
| 1314 (Assert (not (all-completions "" '((" hidden" . "object"))))) | |
| 1315 (Assert (all-completions " " '((" hidden" . "object")))) | |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1316 |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1317 (let* ((literal-with-uninterned |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1318 '(first-element |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1319 [#1=#:G32976 #2=#:G32974 #3=#:G32971 #4=#:G32969 alias |
|
4396
e97f16fb2e25
Don't assume lisp-tests.el will be correctly read as UTF-8.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4394
diff
changeset
|
1320 #s(hash-table size 256 data (969 ?\xF9 55 ?7 166 ?\xA6)) |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1321 #5=#:G32970 #6=#:G32972])) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1322 (print-readably t) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1323 (print-gensym t) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1324 (printed-with-uninterned (prin1-to-string literal-with-uninterned)) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1325 (awkward-regexp "#1=#") |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1326 (first-match-start (string-match awkward-regexp |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1327 printed-with-uninterned))) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1328 (Assert (null (string-match awkward-regexp printed-with-uninterned |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1329 (1+ first-match-start))))) |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1330 |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1331 (let ((char-table-with-string #s(char-table data (?\x00 "text"))) |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1332 (char-table-with-symbol #s(char-table data (?\x00 text)))) |
|
4582
00ed9903a988
Fix make check after my last change.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4580
diff
changeset
|
1333 (Assert (not (string-equal (prin1-to-string char-table-with-string) |
|
00ed9903a988
Fix make check after my last change.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4580
diff
changeset
|
1334 (prin1-to-string char-table-with-symbol))) |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1335 "Check that char table elements are quoted correctly when printing")) |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1336 |