git.chise.org Git - chise/xemacs-chise.git.1/blob - tests/automated/lisp-tests.el

   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 Emacs.
  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))
 232
 233 ;; Test `-'
 234 (Check-Error wrong-number-of-arguments (-))
 235 (Assert (eq (- 0) 0))
 236 (Assert (eq (- 1) -1))
 237 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1)))
 238   (Assert (= (+ 1 one) 2))
 239   (Assert (= (+ one) 1))
 240   (Assert (= (+ one) one))
 241   (Assert (= (- one) -1))
 242   (Assert (= (- one one) 0))
 243   (Assert (= (- one one one) -1))
 244   (Assert (= (+ one 1) 2))
 245   (dolist (zero `(0 0.0 ?\0))
 246     (Assert (= (+ 1 zero) 1))
 247     (Assert (= (+ zero 1) 1))
 248     (Assert (= (- zero) zero))
 249     (Assert (= (- zero) 0))
 250     (Assert (= (- zero zero) 0))
 251     (Assert (= (- zero one one) -2))))
 252
 253 (Assert (= (- 1.5 1) .5))
 254 (Assert (= (- 1 1.5) (- .5)))
 255
 256 ;; Test `/'
 257
 258 ;; Test division by zero errors
 259 (dolist (zero `(0 0.0 ?\0))
 260   (Check-Error arith-error (/ zero))
 261   (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
 262     (Check-Error arith-error (/ n1 zero))
 263     (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3)))
 264       (Check-Error arith-error (/ n1 n2 zero)))))
 265
 266 ;; Other tests for `/'
 267 (Check-Error wrong-number-of-arguments (/))
 268 (let (x)
 269   (Assert (= (/ (setq x 2))   0))
 270   (Assert (= (/ (setq x 2.0)) 0.5)))
 271
 272 (dolist (six `(6 6.0 ?\06))
 273   (dolist (two `(2 2.0 ?\02))
 274     (dolist (three `(3 3.0 ?\03))
 275       (Assert (= (/ six two) three)))))
 276
 277 (dolist (three `(3 3.0 ?\03))
 278   (Assert (= (/ three 2.0) 1.5)))
 279 (dolist (two `(2 2.0 ?\02))
 280   (Assert (= (/ 3.0 two) 1.5)))
 281
 282 ;; Test `*'
 283 (Assert (= 1 (*)))
 284
 285 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
 286   (Assert (= 1 (* one))))
 287
 288 (dolist (two `(2 2.0 ?\02))
 289   (Assert (= 2 (* two))))
 290
 291 (dolist (six `(6 6.0 ?\06))
 292   (dolist (two `(2 2.0 ?\02))
 293     (dolist (three `(3 3.0 ?\03))
 294       (Assert (= (* three two) six)))))
 295
 296 (dolist (three `(3 3.0 ?\03))
 297   (dolist (two `(2 2.0 ?\02))
 298     (Assert (= (* 1.5 two) three))
 299     (dolist (five `(5 5.0 ?\05))
 300       (Assert (= 30 (* five two three))))))
 301
 302 ;; Test `+'
 303 (Assert (= 0 (+)))
 304
 305 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
 306   (Assert (= 1 (+ one))))
 307
 308 (dolist (two `(2 2.0 ?\02))
 309   (Assert (= 2 (+ two))))
 310
 311 (dolist (five `(5 5.0 ?\05))
 312   (dolist (two `(2 2.0 ?\02))
 313     (dolist (three `(3 3.0 ?\03))
 314       (Assert (= (+ three two) five))
 315       (Assert (= 10 (+ five two three))))))
 316
 317 ;; Test `max', `min'
 318 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
 319   (Assert (= one (max one)))
 320   (Assert (= one (max one one)))
 321   (Assert (= one (max one one one)))
 322   (Assert (= one (min one)))
 323   (Assert (= one (min one one)))
 324   (Assert (= one (min one one one)))
 325   (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2)))
 326     (Assert (= one (min one two)))
 327     (Assert (= one (min one two two)))
 328     (Assert (= one (min two two one)))
 329     (Assert (= two (max one two)))
 330     (Assert (= two (max one two two)))
 331     (Assert (= two (max two two one)))))
 332
 333 ;;-----------------------------------------------------
 334 ;; Logical bit-twiddling operations
 335 ;;-----------------------------------------------------
 336 (Assert (= (logxor)  0))
 337 (Assert (= (logior)  0))
 338 (Assert (= (logand) -1))
 339
 340 (Check-Error wrong-type-argument (logxor 3.0))
 341 (Check-Error wrong-type-argument (logior 3.0))
 342 (Check-Error wrong-type-argument (logand 3.0))
 343
 344 (dolist (three `(3 ?\03))
 345   (Assert (eq 3 (logand three)))
 346   (Assert (eq 3 (logxor three)))
 347   (Assert (eq 3 (logior three)))
 348   (Assert (eq 3 (logand three three)))
 349   (Assert (eq 0 (logxor three three)))
 350   (Assert (eq 3 (logior three three))))
 351
 352 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
 353   (dolist (two `(2 ?\02))
 354     (Assert (eq 0 (logand one two)))
 355     (Assert (eq 3 (logior one two)))
 356     (Assert (eq 3 (logxor one two))))
 357   (dolist (three `(3 ?\03))
 358     (Assert (eq 1 (logand one three)))
 359     (Assert (eq 3 (logior one three)))
 360     (Assert (eq 2 (logxor one three)))))
 361
 362 ;;-----------------------------------------------------
 363 ;; Test `%', mod
 364 ;;-----------------------------------------------------
 365 (Check-Error wrong-number-of-arguments (%))
 366 (Check-Error wrong-number-of-arguments (% 1))
 367 (Check-Error wrong-number-of-arguments (% 1 2 3))
 368
 369 (Check-Error wrong-number-of-arguments (mod))
 370 (Check-Error wrong-number-of-arguments (mod 1))
 371 (Check-Error wrong-number-of-arguments (mod 1 2 3))
 372
 373 (Check-Error wrong-type-argument (% 10.0 2))
 374 (Check-Error wrong-type-argument (% 10 2.0))
 375
 376 (dotimes (j 30)
 377   (let ((x (- (random) (random))))
 378     (Assert (eq x (+ (% x 17) (* (/ x 17) 17))))
 379     (Assert (eq (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))))
 380     (Assert (eq (% x -17) (- (% (- x) 17))))
 381     ))
 382
 383 (macrolet
 384     ((division-test (seven)
 385     `(progn
 386        (Assert (eq (% ,seven      2)  1))
 387        (Assert (eq (% ,seven     -2)  1))
 388        (Assert (eq (% (- ,seven)  2) -1))
 389        (Assert (eq (% (- ,seven) -2) -1))
 390
 391        (Assert (eq (% ,seven      4)  3))
 392        (Assert (eq (% ,seven     -4)  3))
 393        (Assert (eq (% (- ,seven)  4) -3))
 394        (Assert (eq (% (- ,seven) -4) -3))
 395
 396        (Assert (eq (%  35 ,seven)     0))
 397        (Assert (eq (% -35 ,seven)     0))
 398        (Assert (eq (%  35 (- ,seven)) 0))
 399        (Assert (eq (% -35 (- ,seven)) 0))
 400
 401        (Assert (eq (mod ,seven      2)  1))
 402        (Assert (eq (mod ,seven     -2) -1))
 403        (Assert (eq (mod (- ,seven)  2)  1))
 404        (Assert (eq (mod (- ,seven) -2) -1))
 405
 406        (Assert (eq (mod ,seven      4)  3))
 407        (Assert (eq (mod ,seven     -4) -1))
 408        (Assert (eq (mod (- ,seven)  4)  1))
 409        (Assert (eq (mod (- ,seven) -4) -3))
 410
 411        (Assert (eq (mod  35 ,seven)     0))
 412        (Assert (eq (mod -35 ,seven)     0))
 413        (Assert (eq (mod  35 (- ,seven)) 0))
 414        (Assert (eq (mod -35 (- ,seven)) 0))
 415
 416        (Assert (= (mod ,seven      2.0)  1.0))
 417        (Assert (= (mod ,seven     -2.0) -1.0))
 418        (Assert (= (mod (- ,seven)  2.0)  1.0))
 419        (Assert (= (mod (- ,seven) -2.0) -1.0))
 420
 421        (Assert (= (mod ,seven      4.0)  3.0))
 422        (Assert (= (mod ,seven     -4.0) -1.0))
 423        (Assert (= (mod (- ,seven)  4.0)  1.0))
 424        (Assert (= (mod (- ,seven) -4.0) -3.0))
 425
 426        (Assert (eq (% 0 ,seven) 0))
 427        (Assert (eq (% 0 (- ,seven)) 0))
 428
 429        (Assert (eq (mod 0 ,seven) 0))
 430        (Assert (eq (mod 0 (- ,seven)) 0))
 431
 432        (Assert (= (mod 0.0 ,seven) 0.0))
 433        (Assert (= (mod 0.0 (- ,seven)) 0.0)))))
 434
 435   (division-test 7)
 436   (division-test ?\07)
 437   (division-test (Int-to-Marker 7)))
 438
 439
 440
 441 ;;-----------------------------------------------------
 442 ;; Arithmetic comparison operations
 443 ;;-----------------------------------------------------
 444 (Check-Error wrong-number-of-arguments (=))
 445 (Check-Error wrong-number-of-arguments (<))
 446 (Check-Error wrong-number-of-arguments (>))
 447 (Check-Error wrong-number-of-arguments (<=))
 448 (Check-Error wrong-number-of-arguments (>=))
 449 (Check-Error wrong-number-of-arguments (/=))
 450
 451 ;; One argument always yields t
 452 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do
 453   (Assert (eq t (=  x)))
 454   (Assert (eq t (<  x)))
 455   (Assert (eq t (>  x)))
 456   (Assert (eq t (>= x)))
 457   (Assert (eq t (<= x)))
 458   (Assert (eq t (/= x)))
 459   )
 460
 461 ;; Type checking
 462 (Check-Error wrong-type-argument (=  'foo 1))
 463 (Check-Error wrong-type-argument (<= 'foo 1))
 464 (Check-Error wrong-type-argument (>= 'foo 1))
 465 (Check-Error wrong-type-argument (<  'foo 1))
 466 (Check-Error wrong-type-argument (>  'foo 1))
 467 (Check-Error wrong-type-argument (/= 'foo 1))
 468
 469 ;; Meat
 470 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
 471   (dolist (two `(2 2.0 ?\02))
 472     (Assert (<  one two))
 473     (Assert (<= one two))
 474     (Assert (<= two two))
 475     (Assert (>  two one))
 476     (Assert (>= two one))
 477     (Assert (>= two two))
 478     (Assert (/= one two))
 479     (Assert (not (/= two two)))
 480     (Assert (not (< one one)))
 481     (Assert (not (> one one)))
 482     (Assert (<= one one two two))
 483     (Assert (not (< one one two two)))
 484     (Assert (>= two two one one))
 485     (Assert (not (> two two one one)))
 486     (Assert (= one one one))
 487     (Assert (not (= one one one two)))
 488     (Assert (not (/= one two one)))
 489     ))
 490
 491 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
 492   (dolist (two `(2 2.0 ?\02))
 493     (Assert (<  one two))
 494     (Assert (<= one two))
 495     (Assert (<= two two))
 496     (Assert (>  two one))
 497     (Assert (>= two one))
 498     (Assert (>= two two))
 499     (Assert (/= one two))
 500     (Assert (not (/= two two)))
 501     (Assert (not (< one one)))
 502     (Assert (not (> one one)))
 503     (Assert (<= one one two two))
 504     (Assert (not (< one one two two)))
 505     (Assert (>= two two one one))
 506     (Assert (not (> two two one one)))
 507     (Assert (= one one one))
 508     (Assert (not (= one one one two)))
 509     (Assert (not (/= one two one)))
 510     ))
 511
 512 ;; ad-hoc
 513 (Assert (< 1 2))
 514 (Assert (< 1 2 3 4 5 6))
 515 (Assert (not (< 1 1)))
 516 (Assert (not (< 2 1)))
 517
 518
 519 (Assert (not (< 1 1)))
 520 (Assert (< 1 2 3 4 5 6))
 521 (Assert (<= 1 2 3 4 5 6))
 522 (Assert (<= 1 2 3 4 5 6 6))
 523 (Assert (not (< 1 2 3 4 5 6 6)))
 524 (Assert (<= 1 1))
 525
 526 (Assert (not (eq (point) (point-marker))))
 527 (Assert (= 1 (Int-to-Marker 1)))
 528 (Assert (= (point) (point-marker)))
 529
 530 ;;-----------------------------------------------------
 531 ;; testing list-walker functions
 532 ;;-----------------------------------------------------
 533 (macrolet
 534     ((test-fun
 535       (fun)
 536       `(progn
 537          (Check-Error wrong-number-of-arguments (,fun))
 538          (Check-Error wrong-number-of-arguments (,fun nil))
 539          (Check-Error malformed-list (,fun nil 1))
 540          ,@(loop for n in `(1 2 2000)
 541              collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
 542      (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))))
 543
 544   (test-funs member old-member
 545              memq   old-memq
 546              assoc  old-assoc
 547              rassoc old-rassoc
 548              rassq  old-rassq
 549              delete old-delete
 550              delq   old-delq
 551              remassoc remassq remrassoc remrassq))
 552
 553 (let ((x '((1 . 2) 3 (4 . 5))))
 554   (Assert (eq (assoc  1 x) (car x)))
 555   (Assert (eq (assq   1 x) (car x)))
 556   (Assert (eq (rassoc 1 x) nil))
 557   (Assert (eq (rassq  1 x) nil))
 558   (Assert (eq (assoc  2 x) nil))
 559   (Assert (eq (assq   2 x) nil))
 560   (Assert (eq (rassoc 2 x) (car x)))
 561   (Assert (eq (rassq  2 x) (car x)))
 562   (Assert (eq (assoc  3 x) nil))
 563   (Assert (eq (assq   3 x) nil))
 564   (Assert (eq (rassoc 3 x) nil))
 565   (Assert (eq (rassq  3 x) nil))
 566   (Assert (eq (assoc  4 x) (caddr x)))
 567   (Assert (eq (assq   4 x) (caddr x)))
 568   (Assert (eq (rassoc 4 x) nil))
 569   (Assert (eq (rassq  4 x) nil))
 570   (Assert (eq (assoc  5 x) nil))
 571   (Assert (eq (assq   5 x) nil))
 572   (Assert (eq (rassoc 5 x) (caddr x)))
 573   (Assert (eq (rassq  5 x) (caddr x)))
 574   (Assert (eq (assoc  6 x) nil))
 575   (Assert (eq (assq   6 x) nil))
 576   (Assert (eq (rassoc 6 x) nil))
 577   (Assert (eq (rassq  6 x) nil)))
 578
 579 (let ((x '(("1" . "2") "3" ("4" . "5"))))
 580   (Assert (eq (assoc  "1" x) (car x)))
 581   (Assert (eq (assq   "1" x) nil))
 582   (Assert (eq (rassoc "1" x) nil))
 583   (Assert (eq (rassq  "1" x) nil))
 584   (Assert (eq (assoc  "2" x) nil))
 585   (Assert (eq (assq   "2" x) nil))
 586   (Assert (eq (rassoc "2" x) (car x)))
 587   (Assert (eq (rassq  "2" x) nil))
 588   (Assert (eq (assoc  "3" x) nil))
 589   (Assert (eq (assq   "3" x) nil))
 590   (Assert (eq (rassoc "3" x) nil))
 591   (Assert (eq (rassq  "3" x) nil))
 592   (Assert (eq (assoc  "4" x) (caddr x)))
 593   (Assert (eq (assq   "4" x) nil))
 594   (Assert (eq (rassoc "4" x) nil))
 595   (Assert (eq (rassq  "4" x) nil))
 596   (Assert (eq (assoc  "5" x) nil))
 597   (Assert (eq (assq   "5" x) nil))
 598   (Assert (eq (rassoc "5" x) (caddr x)))
 599   (Assert (eq (rassq  "5" x) nil))
 600   (Assert (eq (assoc  "6" x) nil))
 601   (Assert (eq (assq   "6" x) nil))
 602   (Assert (eq (rassoc "6" x) nil))
 603   (Assert (eq (rassq  "6" x) nil)))
 604
 605 (flet ((a () (list '(1 . 2) 3 '(4 . 5))))
 606   (Assert (let* ((x (a)) (y (remassoc  1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 607   (Assert (let* ((x (a)) (y (remassq   1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 608   (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a)))))
 609   (Assert (let* ((x (a)) (y (remrassq  1 x))) (and (eq x y) (equal y (a)))))
 610
 611   (Assert (let* ((x (a)) (y (remassoc  2 x))) (and (eq x y) (equal y (a)))))
 612   (Assert (let* ((x (a)) (y (remassq   2 x))) (and (eq x y) (equal y (a)))))
 613   (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 614   (Assert (let* ((x (a)) (y (remrassq  2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 615
 616   (Assert (let* ((x (a)) (y (remassoc  3 x))) (and (eq x y) (equal y (a)))))
 617   (Assert (let* ((x (a)) (y (remassq   3 x))) (and (eq x y) (equal y (a)))))
 618   (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a)))))
 619   (Assert (let* ((x (a)) (y (remrassq  3 x))) (and (eq x y) (equal y (a)))))
 620
 621   (Assert (let* ((x (a)) (y (remassoc  4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
 622   (Assert (let* ((x (a)) (y (remassq   4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
 623   (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a)))))
 624   (Assert (let* ((x (a)) (y (remrassq  4 x))) (and (eq x y) (equal y (a)))))
 625
 626   (Assert (let* ((x (a)) (y (remassoc  5 x))) (and (eq x y) (equal y (a)))))
 627   (Assert (let* ((x (a)) (y (remassq   5 x))) (and (eq x y) (equal y (a)))))
 628   (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
 629   (Assert (let* ((x (a)) (y (remrassq  5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
 630
 631   (Assert (let* ((x (a)) (y (remassoc  6 x))) (and (eq x y) (equal y (a)))))
 632   (Assert (let* ((x (a)) (y (remassq   6 x))) (and (eq x y) (equal y (a)))))
 633   (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a)))))
 634   (Assert (let* ((x (a)) (y (remrassq  6 x))) (and (eq x y) (equal y (a)))))
 635
 636   (Assert (let* ((x (a)) (y (delete     3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
 637   (Assert (let* ((x (a)) (y (delq       3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
 638   (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
 639   (Assert (let* ((x (a)) (y (old-delq   3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
 640
 641   (Assert (let* ((x (a)) (y (delete     '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 642   (Assert (let* ((x (a)) (y (delq       '(1 . 2) x))) (and      (eq x y)  (equal y (a)))))
 643   (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 644   (Assert (let* ((x (a)) (y (old-delq   '(1 . 2) x))) (and      (eq x y)  (equal y (a)))))
 645   )
 646
 647
 648
 649 (flet ((a () (list '("1" . "2") "3" '("4" . "5"))))
 650   (Assert (let* ((x (a)) (y (remassoc  "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
 651   (Assert (let* ((x (a)) (y (remassq   "1" x))) (and (eq x y) (equal y (a)))))
 652   (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a)))))
 653   (Assert (let* ((x (a)) (y (remrassq  "1" x))) (and (eq x y) (equal y (a)))))
 654
 655   (Assert (let* ((x (a)) (y (remassoc  "2" x))) (and (eq x y) (equal y (a)))))
 656   (Assert (let* ((x (a)) (y (remassq   "2" x))) (and (eq x y) (equal y (a)))))
 657   (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
 658   (Assert (let* ((x (a)) (y (remrassq  "2" x))) (and (eq x y) (equal y (a)))))
 659
 660   (Assert (let* ((x (a)) (y (remassoc  "3" x))) (and (eq x y) (equal y (a)))))
 661   (Assert (let* ((x (a)) (y (remassq   "3" x))) (and (eq x y) (equal y (a)))))
 662   (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a)))))
 663   (Assert (let* ((x (a)) (y (remrassq  "3" x))) (and (eq x y) (equal y (a)))))
 664
 665   (Assert (let* ((x (a)) (y (remassoc  "4" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
 666   (Assert (let* ((x (a)) (y (remassq   "4" x))) (and (eq x y) (equal y (a)))))
 667   (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a)))))
 668   (Assert (let* ((x (a)) (y (remrassq  "4" x))) (and (eq x y) (equal y (a)))))
 669
 670   (Assert (let* ((x (a)) (y (remassoc  "5" x))) (and (eq x y) (equal y (a)))))
 671   (Assert (let* ((x (a)) (y (remassq   "5" x))) (and (eq x y) (equal y (a)))))
 672   (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
 673   (Assert (let* ((x (a)) (y (remrassq  "5" x))) (and (eq x y) (equal y (a)))))
 674
 675   (Assert (let* ((x (a)) (y (remassoc  "6" x))) (and (eq x y) (equal y (a)))))
 676   (Assert (let* ((x (a)) (y (remassq   "6" x))) (and (eq x y) (equal y (a)))))
 677   (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a)))))
 678   (Assert (let* ((x (a)) (y (remrassq  "6" x))) (and (eq x y) (equal y (a))))))
 679
 680 ;;-----------------------------------------------------
 681 ;; function-max-args, function-min-args
 682 ;;-----------------------------------------------------
 683 (defmacro check-function-argcounts (fun min max)
 684   `(progn
 685      (Assert (eq (function-min-args ,fun) ,min))
 686      (Assert (eq (function-max-args ,fun) ,max))))
 687
 688 (check-function-argcounts 'prog1 1 nil)         ; special form
 689 (check-function-argcounts 'command-execute 1 3) ; normal subr
 690 (check-function-argcounts 'funcall 1 nil)       ; `MANY' subr
 691 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
 692
 693 ;; Test interpreted and compiled functions
 694 (loop for (arglist min max) in
 695   '(((arg1 arg2 &rest args) 2 nil)
 696     ((arg1 arg2 &optional arg3 arg4) 2 4)
 697     ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil)
 698     (() 0 0))
 699   do
 700   (eval
 701    `(progn
 702       (defun test-fun ,arglist nil)
 703       (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
 704       (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
 705
 706 ;;-----------------------------------------------------
 707 ;; Detection of cyclic variable indirection loops
 708 ;;-----------------------------------------------------
 709 (fset 'test-sym1 'test-sym1)
 710 (Check-Error cyclic-function-indirection (test-sym1))
 711
 712 (fset 'test-sym1 'test-sym2)
 713 (fset 'test-sym2 'test-sym1)
 714 (Check-Error cyclic-function-indirection (test-sym1))
 715 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops!
 716 (fmakunbound 'test-sym2)
 717
 718 ;;-----------------------------------------------------
 719 ;; Test `type-of'
 720 ;;-----------------------------------------------------
 721 (Assert (eq (type-of load-path) 'cons))
 722 (Assert (eq (type-of obarray) 'vector))
 723 (Assert (eq (type-of 42) 'integer))
 724 (Assert (eq (type-of ?z) 'character))
 725 (Assert (eq (type-of "42") 'string))
 726 (Assert (eq (type-of 'foo) 'symbol))
 727 (Assert (eq (type-of (selected-device)) 'device))