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.
  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 (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum))
 233 (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum))
 234
 235 ;; Test `-'
 236 (Check-Error wrong-number-of-arguments (-))
 237 (Assert (eq (- 0) 0))
 238 (Assert (eq (- 1) -1))
 239 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1)))
 240   (Assert (= (+ 1 one) 2))
 241   (Assert (= (+ one) 1))
 242   (Assert (= (+ one) one))
 243   (Assert (= (- one) -1))
 244   (Assert (= (- one one) 0))
 245   (Assert (= (- one one one) -1))
 246   (Assert (= (+ one 1) 2))
 247   (dolist (zero '(0 0.0 ?\0))
 248     (Assert (= (+ 1 zero) 1))
 249     (Assert (= (+ zero 1) 1))
 250     (Assert (= (- zero) zero))
 251     (Assert (= (- zero) 0))
 252     (Assert (= (- zero zero) 0))
 253     (Assert (= (- zero one one) -2))))
 254
 255 (Assert (= (- 1.5 1) .5))
 256 (Assert (= (- 1 1.5) (- .5)))
 257
 258 (Assert (eq (1- most-negative-fixnum) most-positive-fixnum))
 259 (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum))
 260
 261 ;; Test `/'
 262
 263 ;; Test division by zero errors
 264 (dolist (zero '(0 0.0 ?\0))
 265   (Check-Error arith-error (/ zero))
 266   (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42)))
 267     (Check-Error arith-error (/ n1 zero))
 268     (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3)))
 269       (Check-Error arith-error (/ n1 n2 zero)))))
 270
 271 ;; Other tests for `/'
 272 (Check-Error wrong-number-of-arguments (/))
 273 (let (x)
 274   (Assert (= (/ (setq x 2))   0))
 275   (Assert (= (/ (setq x 2.0)) 0.5)))
 276
 277 (dolist (six '(6 6.0 ?\06))
 278   (dolist (two '(2 2.0 ?\02))
 279     (dolist (three '(3 3.0 ?\03))
 280       (Assert (= (/ six two) three)))))
 281
 282 (dolist (three '(3 3.0 ?\03))
 283   (Assert (= (/ three 2.0) 1.5)))
 284 (dolist (two '(2 2.0 ?\02))
 285   (Assert (= (/ 3.0 two) 1.5)))
 286
 287 ;; Test `*'
 288 (Assert (= 1 (*)))
 289
 290 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
 291   (Assert (= 1 (* one))))
 292
 293 (dolist (two '(2 2.0 ?\02))
 294   (Assert (= 2 (* two))))
 295
 296 (dolist (six '(6 6.0 ?\06))
 297   (dolist (two '(2 2.0 ?\02))
 298     (dolist (three '(3 3.0 ?\03))
 299       (Assert (= (* three two) six)))))
 300
 301 (dolist (three '(3 3.0 ?\03))
 302   (dolist (two '(2 2.0 ?\02))
 303     (Assert (= (* 1.5 two) three))
 304     (dolist (five '(5 5.0 ?\05))
 305       (Assert (= 30 (* five two three))))))
 306
 307 ;; Test `+'
 308 (Assert (= 0 (+)))
 309
 310 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
 311   (Assert (= 1 (+ one))))
 312
 313 (dolist (two '(2 2.0 ?\02))
 314   (Assert (= 2 (+ two))))
 315
 316 (dolist (five '(5 5.0 ?\05))
 317   (dolist (two '(2 2.0 ?\02))
 318     (dolist (three '(3 3.0 ?\03))
 319       (Assert (= (+ three two) five))
 320       (Assert (= 10 (+ five two three))))))
 321
 322 ;; Test `max', `min'
 323 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1)))
 324   (Assert (= one (max one)))
 325   (Assert (= one (max one one)))
 326   (Assert (= one (max one one one)))
 327   (Assert (= one (min one)))
 328   (Assert (= one (min one one)))
 329   (Assert (= one (min one one one)))
 330   (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2)))
 331     (Assert (= one (min one two)))
 332     (Assert (= one (min one two two)))
 333     (Assert (= one (min two two one)))
 334     (Assert (= two (max one two)))
 335     (Assert (= two (max one two two)))
 336     (Assert (= two (max two two one)))))
 337
 338 ;;-----------------------------------------------------
 339 ;; Logical bit-twiddling operations
 340 ;;-----------------------------------------------------
 341 (Assert (= (logxor)  0))
 342 (Assert (= (logior)  0))
 343 (Assert (= (logand) -1))
 344
 345 (Check-Error wrong-type-argument (logxor 3.0))
 346 (Check-Error wrong-type-argument (logior 3.0))
 347 (Check-Error wrong-type-argument (logand 3.0))
 348
 349 (dolist (three '(3 ?\03))
 350   (Assert (eq 3 (logand three)))
 351   (Assert (eq 3 (logxor three)))
 352   (Assert (eq 3 (logior three)))
 353   (Assert (eq 3 (logand three three)))
 354   (Assert (eq 0 (logxor three three)))
 355   (Assert (eq 3 (logior three three))))
 356
 357 (dolist (one `(1 ?\01 ,(Int-to-Marker 1)))
 358   (dolist (two '(2 ?\02))
 359     (Assert (eq 0 (logand one two)))
 360     (Assert (eq 3 (logior one two)))
 361     (Assert (eq 3 (logxor one two))))
 362   (dolist (three '(3 ?\03))
 363     (Assert (eq 1 (logand one three)))
 364     (Assert (eq 3 (logior one three)))
 365     (Assert (eq 2 (logxor one three)))))
 366
 367 ;;-----------------------------------------------------
 368 ;; Test `%', mod
 369 ;;-----------------------------------------------------
 370 (Check-Error wrong-number-of-arguments (%))
 371 (Check-Error wrong-number-of-arguments (% 1))
 372 (Check-Error wrong-number-of-arguments (% 1 2 3))
 373
 374 (Check-Error wrong-number-of-arguments (mod))
 375 (Check-Error wrong-number-of-arguments (mod 1))
 376 (Check-Error wrong-number-of-arguments (mod 1 2 3))
 377
 378 (Check-Error wrong-type-argument (% 10.0 2))
 379 (Check-Error wrong-type-argument (% 10 2.0))
 380
 381 (dotimes (j 30)
 382   (let ((x (- (random) (random))))
 383     (Assert (eq x (+ (% x 17) (* (/ x 17) 17))))
 384     (Assert (eq (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))))
 385     (Assert (eq (% x -17) (- (% (- x) 17))))
 386     ))
 387
 388 (macrolet
 389     ((division-test (seven)
 390     `(progn
 391        (Assert (eq (% ,seven      2)  1))
 392        (Assert (eq (% ,seven     -2)  1))
 393        (Assert (eq (% (- ,seven)  2) -1))
 394        (Assert (eq (% (- ,seven) -2) -1))
 395
 396        (Assert (eq (% ,seven      4)  3))
 397        (Assert (eq (% ,seven     -4)  3))
 398        (Assert (eq (% (- ,seven)  4) -3))
 399        (Assert (eq (% (- ,seven) -4) -3))
 400
 401        (Assert (eq (%  35 ,seven)     0))
 402        (Assert (eq (% -35 ,seven)     0))
 403        (Assert (eq (%  35 (- ,seven)) 0))
 404        (Assert (eq (% -35 (- ,seven)) 0))
 405
 406        (Assert (eq (mod ,seven      2)  1))
 407        (Assert (eq (mod ,seven     -2) -1))
 408        (Assert (eq (mod (- ,seven)  2)  1))
 409        (Assert (eq (mod (- ,seven) -2) -1))
 410
 411        (Assert (eq (mod ,seven      4)  3))
 412        (Assert (eq (mod ,seven     -4) -1))
 413        (Assert (eq (mod (- ,seven)  4)  1))
 414        (Assert (eq (mod (- ,seven) -4) -3))
 415
 416        (Assert (eq (mod  35 ,seven)     0))
 417        (Assert (eq (mod -35 ,seven)     0))
 418        (Assert (eq (mod  35 (- ,seven)) 0))
 419        (Assert (eq (mod -35 (- ,seven)) 0))
 420
 421        (Assert (= (mod ,seven      2.0)  1.0))
 422        (Assert (= (mod ,seven     -2.0) -1.0))
 423        (Assert (= (mod (- ,seven)  2.0)  1.0))
 424        (Assert (= (mod (- ,seven) -2.0) -1.0))
 425
 426        (Assert (= (mod ,seven      4.0)  3.0))
 427        (Assert (= (mod ,seven     -4.0) -1.0))
 428        (Assert (= (mod (- ,seven)  4.0)  1.0))
 429        (Assert (= (mod (- ,seven) -4.0) -3.0))
 430
 431        (Assert (eq (% 0 ,seven) 0))
 432        (Assert (eq (% 0 (- ,seven)) 0))
 433
 434        (Assert (eq (mod 0 ,seven) 0))
 435        (Assert (eq (mod 0 (- ,seven)) 0))
 436
 437        (Assert (= (mod 0.0 ,seven) 0.0))
 438        (Assert (= (mod 0.0 (- ,seven)) 0.0)))))
 439
 440   (division-test 7)
 441   (division-test ?\07)
 442   (division-test (Int-to-Marker 7)))
 443
 444
 445
 446 ;;-----------------------------------------------------
 447 ;; Arithmetic comparison operations
 448 ;;-----------------------------------------------------
 449 (Check-Error wrong-number-of-arguments (=))
 450 (Check-Error wrong-number-of-arguments (<))
 451 (Check-Error wrong-number-of-arguments (>))
 452 (Check-Error wrong-number-of-arguments (<=))
 453 (Check-Error wrong-number-of-arguments (>=))
 454 (Check-Error wrong-number-of-arguments (/=))
 455
 456 ;; One argument always yields t
 457 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do
 458   (Assert (eq t (=  x)))
 459   (Assert (eq t (<  x)))
 460   (Assert (eq t (>  x)))
 461   (Assert (eq t (>= x)))
 462   (Assert (eq t (<= x)))
 463   (Assert (eq t (/= x)))
 464   )
 465
 466 ;; Type checking
 467 (Check-Error wrong-type-argument (=  'foo 1))
 468 (Check-Error wrong-type-argument (<= 'foo 1))
 469 (Check-Error wrong-type-argument (>= 'foo 1))
 470 (Check-Error wrong-type-argument (<  'foo 1))
 471 (Check-Error wrong-type-argument (>  'foo 1))
 472 (Check-Error wrong-type-argument (/= 'foo 1))
 473
 474 ;; Meat
 475 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
 476   (dolist (two '(2 2.0 ?\02))
 477     (Assert (<  one two))
 478     (Assert (<= one two))
 479     (Assert (<= two two))
 480     (Assert (>  two one))
 481     (Assert (>= two one))
 482     (Assert (>= two two))
 483     (Assert (/= one two))
 484     (Assert (not (/= two two)))
 485     (Assert (not (< one one)))
 486     (Assert (not (> one one)))
 487     (Assert (<= one one two two))
 488     (Assert (not (< one one two two)))
 489     (Assert (>= two two one one))
 490     (Assert (not (> two two one one)))
 491     (Assert (= one one one))
 492     (Assert (not (= one one one two)))
 493     (Assert (not (/= one two one)))
 494     ))
 495
 496 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01))
 497   (dolist (two '(2 2.0 ?\02))
 498     (Assert (<  one two))
 499     (Assert (<= one two))
 500     (Assert (<= two two))
 501     (Assert (>  two one))
 502     (Assert (>= two one))
 503     (Assert (>= two two))
 504     (Assert (/= one two))
 505     (Assert (not (/= two two)))
 506     (Assert (not (< one one)))
 507     (Assert (not (> one one)))
 508     (Assert (<= one one two two))
 509     (Assert (not (< one one two two)))
 510     (Assert (>= two two one one))
 511     (Assert (not (> two two one one)))
 512     (Assert (= one one one))
 513     (Assert (not (= one one one two)))
 514     (Assert (not (/= one two one)))
 515     ))
 516
 517 ;; ad-hoc
 518 (Assert (< 1 2))
 519 (Assert (< 1 2 3 4 5 6))
 520 (Assert (not (< 1 1)))
 521 (Assert (not (< 2 1)))
 522
 523
 524 (Assert (not (< 1 1)))
 525 (Assert (< 1 2 3 4 5 6))
 526 (Assert (<= 1 2 3 4 5 6))
 527 (Assert (<= 1 2 3 4 5 6 6))
 528 (Assert (not (< 1 2 3 4 5 6 6)))
 529 (Assert (<= 1 1))
 530
 531 (Assert (not (eq (point) (point-marker))))
 532 (Assert (= 1 (Int-to-Marker 1)))
 533 (Assert (= (point) (point-marker)))
 534
 535 ;;-----------------------------------------------------
 536 ;; testing list-walker functions
 537 ;;-----------------------------------------------------
 538 (macrolet
 539     ((test-fun
 540       (fun)
 541       `(progn
 542          (Check-Error wrong-number-of-arguments (,fun))
 543          (Check-Error wrong-number-of-arguments (,fun nil))
 544          (Check-Error malformed-list (,fun nil 1))
 545          ,@(loop for n in '(1 2 2000)
 546              collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
 547      (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun)))))
 548
 549   (test-funs member old-member
 550              memq   old-memq
 551              assoc  old-assoc
 552              rassoc old-rassoc
 553              rassq  old-rassq
 554              delete old-delete
 555              delq   old-delq
 556              remassoc remassq remrassoc remrassq))
 557
 558 (let ((x '((1 . 2) 3 (4 . 5))))
 559   (Assert (eq (assoc  1 x) (car x)))
 560   (Assert (eq (assq   1 x) (car x)))
 561   (Assert (eq (rassoc 1 x) nil))
 562   (Assert (eq (rassq  1 x) nil))
 563   (Assert (eq (assoc  2 x) nil))
 564   (Assert (eq (assq   2 x) nil))
 565   (Assert (eq (rassoc 2 x) (car x)))
 566   (Assert (eq (rassq  2 x) (car x)))
 567   (Assert (eq (assoc  3 x) nil))
 568   (Assert (eq (assq   3 x) nil))
 569   (Assert (eq (rassoc 3 x) nil))
 570   (Assert (eq (rassq  3 x) nil))
 571   (Assert (eq (assoc  4 x) (caddr x)))
 572   (Assert (eq (assq   4 x) (caddr x)))
 573   (Assert (eq (rassoc 4 x) nil))
 574   (Assert (eq (rassq  4 x) nil))
 575   (Assert (eq (assoc  5 x) nil))
 576   (Assert (eq (assq   5 x) nil))
 577   (Assert (eq (rassoc 5 x) (caddr x)))
 578   (Assert (eq (rassq  5 x) (caddr x)))
 579   (Assert (eq (assoc  6 x) nil))
 580   (Assert (eq (assq   6 x) nil))
 581   (Assert (eq (rassoc 6 x) nil))
 582   (Assert (eq (rassq  6 x) nil)))
 583
 584 (let ((x '(("1" . "2") "3" ("4" . "5"))))
 585   (Assert (eq (assoc  "1" x) (car x)))
 586   (Assert (eq (assq   "1" x) nil))
 587   (Assert (eq (rassoc "1" x) nil))
 588   (Assert (eq (rassq  "1" x) nil))
 589   (Assert (eq (assoc  "2" x) nil))
 590   (Assert (eq (assq   "2" x) nil))
 591   (Assert (eq (rassoc "2" x) (car x)))
 592   (Assert (eq (rassq  "2" x) nil))
 593   (Assert (eq (assoc  "3" x) nil))
 594   (Assert (eq (assq   "3" x) nil))
 595   (Assert (eq (rassoc "3" x) nil))
 596   (Assert (eq (rassq  "3" x) nil))
 597   (Assert (eq (assoc  "4" x) (caddr x)))
 598   (Assert (eq (assq   "4" x) nil))
 599   (Assert (eq (rassoc "4" x) nil))
 600   (Assert (eq (rassq  "4" x) nil))
 601   (Assert (eq (assoc  "5" x) nil))
 602   (Assert (eq (assq   "5" x) nil))
 603   (Assert (eq (rassoc "5" x) (caddr x)))
 604   (Assert (eq (rassq  "5" x) nil))
 605   (Assert (eq (assoc  "6" x) nil))
 606   (Assert (eq (assq   "6" x) nil))
 607   (Assert (eq (rassoc "6" x) nil))
 608   (Assert (eq (rassq  "6" x) nil)))
 609
 610 (flet ((a () (list '(1 . 2) 3 '(4 . 5))))
 611   (Assert (let* ((x (a)) (y (remassoc  1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 612   (Assert (let* ((x (a)) (y (remassq   1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 613   (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a)))))
 614   (Assert (let* ((x (a)) (y (remrassq  1 x))) (and (eq x y) (equal y (a)))))
 615
 616   (Assert (let* ((x (a)) (y (remassoc  2 x))) (and (eq x y) (equal y (a)))))
 617   (Assert (let* ((x (a)) (y (remassq   2 x))) (and (eq x y) (equal y (a)))))
 618   (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 619   (Assert (let* ((x (a)) (y (remrassq  2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 620
 621   (Assert (let* ((x (a)) (y (remassoc  3 x))) (and (eq x y) (equal y (a)))))
 622   (Assert (let* ((x (a)) (y (remassq   3 x))) (and (eq x y) (equal y (a)))))
 623   (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a)))))
 624   (Assert (let* ((x (a)) (y (remrassq  3 x))) (and (eq x y) (equal y (a)))))
 625
 626   (Assert (let* ((x (a)) (y (remassoc  4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
 627   (Assert (let* ((x (a)) (y (remassq   4 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
 628   (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a)))))
 629   (Assert (let* ((x (a)) (y (remrassq  4 x))) (and (eq x y) (equal y (a)))))
 630
 631   (Assert (let* ((x (a)) (y (remassoc  5 x))) (and (eq x y) (equal y (a)))))
 632   (Assert (let* ((x (a)) (y (remassq   5 x))) (and (eq x y) (equal y (a)))))
 633   (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
 634   (Assert (let* ((x (a)) (y (remrassq  5 x))) (and (eq x y) (equal y '((1 . 2) 3)))))
 635
 636   (Assert (let* ((x (a)) (y (remassoc  6 x))) (and (eq x y) (equal y (a)))))
 637   (Assert (let* ((x (a)) (y (remassq   6 x))) (and (eq x y) (equal y (a)))))
 638   (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a)))))
 639   (Assert (let* ((x (a)) (y (remrassq  6 x))) (and (eq x y) (equal y (a)))))
 640
 641   (Assert (let* ((x (a)) (y (delete     3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
 642   (Assert (let* ((x (a)) (y (delq       3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
 643   (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
 644   (Assert (let* ((x (a)) (y (old-delq   3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
 645
 646   (Assert (let* ((x (a)) (y (delete     '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 647   (Assert (let* ((x (a)) (y (delq       '(1 . 2) x))) (and      (eq x y)  (equal y (a)))))
 648   (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
 649   (Assert (let* ((x (a)) (y (old-delq   '(1 . 2) x))) (and      (eq x y)  (equal y (a)))))
 650   )
 651
 652
 653
 654 (flet ((a () (list '("1" . "2") "3" '("4" . "5"))))
 655   (Assert (let* ((x (a)) (y (remassoc  "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
 656   (Assert (let* ((x (a)) (y (remassq   "1" x))) (and (eq x y) (equal y (a)))))
 657   (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a)))))
 658   (Assert (let* ((x (a)) (y (remrassq  "1" x))) (and (eq x y) (equal y (a)))))
 659
 660   (Assert (let* ((x (a)) (y (remassoc  "2" x))) (and (eq x y) (equal y (a)))))
 661   (Assert (let* ((x (a)) (y (remassq   "2" x))) (and (eq x y) (equal y (a)))))
 662   (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
 663   (Assert (let* ((x (a)) (y (remrassq  "2" x))) (and (eq x y) (equal y (a)))))
 664
 665   (Assert (let* ((x (a)) (y (remassoc  "3" x))) (and (eq x y) (equal y (a)))))
 666   (Assert (let* ((x (a)) (y (remassq   "3" x))) (and (eq x y) (equal y (a)))))
 667   (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a)))))
 668   (Assert (let* ((x (a)) (y (remrassq  "3" x))) (and (eq x y) (equal y (a)))))
 669
 670   (Assert (let* ((x (a)) (y (remassoc  "4" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
 671   (Assert (let* ((x (a)) (y (remassq   "4" x))) (and (eq x y) (equal y (a)))))
 672   (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a)))))
 673   (Assert (let* ((x (a)) (y (remrassq  "4" x))) (and (eq x y) (equal y (a)))))
 674
 675   (Assert (let* ((x (a)) (y (remassoc  "5" x))) (and (eq x y) (equal y (a)))))
 676   (Assert (let* ((x (a)) (y (remassq   "5" x))) (and (eq x y) (equal y (a)))))
 677   (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3")))))
 678   (Assert (let* ((x (a)) (y (remrassq  "5" x))) (and (eq x y) (equal y (a)))))
 679
 680   (Assert (let* ((x (a)) (y (remassoc  "6" x))) (and (eq x y) (equal y (a)))))
 681   (Assert (let* ((x (a)) (y (remassq   "6" x))) (and (eq x y) (equal y (a)))))
 682   (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a)))))
 683   (Assert (let* ((x (a)) (y (remrassq  "6" x))) (and (eq x y) (equal y (a))))))
 684
 685 ;;-----------------------------------------------------
 686 ;; function-max-args, function-min-args
 687 ;;-----------------------------------------------------
 688 (defmacro check-function-argcounts (fun min max)
 689   `(progn
 690      (Assert (eq (function-min-args ,fun) ,min))
 691      (Assert (eq (function-max-args ,fun) ,max))))
 692
 693 (check-function-argcounts 'prog1 1 nil)         ; special form
 694 (check-function-argcounts 'command-execute 1 3) ; normal subr
 695 (check-function-argcounts 'funcall 1 nil)       ; `MANY' subr
 696 (check-function-argcounts 'garbage-collect 0 0) ; no args subr
 697
 698 ;; Test interpreted and compiled functions
 699 (loop for (arglist min max) in
 700   '(((arg1 arg2 &rest args) 2 nil)
 701     ((arg1 arg2 &optional arg3 arg4) 2 4)
 702     ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil)
 703     (() 0 0))
 704   do
 705   (eval
 706    `(progn
 707       (defun test-fun ,arglist nil)
 708       (check-function-argcounts '(lambda ,arglist nil) ,min ,max)
 709       (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max))))
 710
 711 ;;-----------------------------------------------------
 712 ;; Detection of cyclic variable indirection loops
 713 ;;-----------------------------------------------------
 714 (fset 'test-sym1 'test-sym1)
 715 (Check-Error cyclic-function-indirection (test-sym1))
 716
 717 (fset 'test-sym1 'test-sym2)
 718 (fset 'test-sym2 'test-sym1)
 719 (Check-Error cyclic-function-indirection (test-sym1))
 720 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops!
 721 (fmakunbound 'test-sym2)
 722
 723 ;;-----------------------------------------------------
 724 ;; Test `type-of'
 725 ;;-----------------------------------------------------
 726 (Assert (eq (type-of load-path) 'cons))
 727 (Assert (eq (type-of obarray) 'vector))
 728 (Assert (eq (type-of 42) 'integer))
 729 (Assert (eq (type-of ?z) 'character))
 730 (Assert (eq (type-of "42") 'string))
 731 (Assert (eq (type-of 'foo) 'symbol))
 732 (Assert (eq (type-of (selected-device)) 'device))
 733
 734 ;;-----------------------------------------------------
 735 ;; Test mapping functions
 736 ;;-----------------------------------------------------
 737 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer)))
 738 (Assert (equal (mapcar #'identity load-path) load-path))
 739 (Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3)))
 740 (Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3)))
 741 (Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3)))
 742 (Assert (equal (mapcar #'identity #*010) '(0 1 0)))
 743
 744 (let ((z 0) (list (make-list 1000 1)))
 745   (mapc (lambda (x) (incf z x)) list)
 746   (Assert (eq 1000 z)))
 747
 748 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer)))
 749 (Assert (equal (mapvector #'identity '(1 2 3)) [1 2 3]))
 750 (Assert (equal (mapvector #'identity "123") [?1 ?2 ?3]))
 751 (Assert (equal (mapvector #'identity [1 2 3]) [1 2 3]))
 752 (Assert (equal (mapvector #'identity #*010) [0 1 0]))
 753
 754 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo"))
 755 (Assert (equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3"))
 756 (Assert (equal (mapconcat #'identity ["1" "2" "3"]  "|") "1|2|3"))
 757
 758 ;; The following 2 functions used to crash XEmacs via mapcar1().
 759 ;; We don't test the actual values of the mapcar, since they're undefined.
 760 (Assert
 761  (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
 762    (mapcar
 763     (lambda (y)
 764       "Devious evil mapping function"
 765       (when (eq (car y) 2) ; go out onto a limb
 766         (setcdr x nil)     ; cut it off behind us
 767         (garbage-collect)) ; are we riding a magic broomstick?
 768       (car y))             ; sorry, hard landing
 769     x)))
 770
 771 (Assert
 772  (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3))))
 773    (mapcar
 774     (lambda (y)
 775       "Devious evil mapping function"
 776       (when (eq (car y) 1)
 777         (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway
 778       (car y))
 779     x)))
 780
 781 ;;-----------------------------------------------------
 782 ;; Test vector functions
 783 ;;-----------------------------------------------------
 784 (Assert (equal [1 2 3] [1 2 3]))
 785 (Assert (equal [] []))
 786 (Assert (not (equal [1 2 3] [])))
 787 (Assert (not (equal [1 2 3] [1 2 4])))
 788 (Assert (not (equal [0 2 3] [1 2 3])))
 789 (Assert (not (equal [1 2 3] [1 2 3 4])))
 790 (Assert (not (equal [1 2 3 4] [1 2 3])))
 791 (Assert (equal (vector 1 2 3) [1 2 3]))
 792 (Assert (equal (make-vector 3 1) [1 1 1]))
 793
 794 ;;-----------------------------------------------------
 795 ;; Test bit-vector functions
 796 ;;-----------------------------------------------------
 797 (Assert (equal #*010 #*010))
 798 (Assert (equal #* #*))
 799 (Assert (not (equal #*010 #*011)))
 800 (Assert (not (equal #*010 #*)))
 801 (Assert (not (equal #*110 #*010)))
 802 (Assert (not (equal #*010 #*0100)))
 803 (Assert (not (equal #*0101 #*010)))
 804 (Assert (equal (bit-vector 0 1 0) #*010))
 805 (Assert (equal (make-bit-vector 3 1) #*111))
 806 (Assert (equal (make-bit-vector 3 0) #*000))
 807
 808 ;;-----------------------------------------------------
 809 ;; Test buffer-local variables used as (ugh!) function parameters
 810 ;;-----------------------------------------------------
 811 (make-local-variable 'test-emacs-buffer-local-variable)
 812 (byte-compile
 813  (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable)
 814    (setq test-emacs-buffer-local-variable nil)))
 815 (test-emacs-buffer-local-parameter nil)
 816
 817 ;;-----------------------------------------------------
 818 ;; Test split-string
 819 ;;-----------------------------------------------------
 820 ;; Hrvoje didn't like these tests so I'm disabling them for now. -sb
 821 ;(Assert (equal (split-string "foo" "") '("" "f" "o" "o" "")))
 822 ;(Assert (equal (split-string "foo" "^") '("" "foo")))
 823 ;(Assert (equal (split-string "foo" "$") '("foo" "")))
 824 (Assert (equal (split-string "foo,bar" ",") '("foo" "bar")))
 825 (Assert (equal (split-string ",foo,bar," ",") '("" "foo" "bar" "")))
 826 (Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,")))
 827 (Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" "")))
 828 (Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" "")))
 829 (Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar")))
 830 (Assert (equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" "")))
 831 (Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar")))
 832 (Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")))
 833
 834 (Assert (not (string-match "\\(\\.\\=\\)" ".")))
 835
 836 ;;-----------------------------------------------------
 837 ;; Test near-text buffer functions.
 838 ;;-----------------------------------------------------
 839 (with-temp-buffer
 840   (erase-buffer)
 841   (Assert (eq (char-before) nil))
 842   (Assert (eq (char-before (point)) nil))
 843   (Assert (eq (char-before (point-marker)) nil))
 844   (Assert (eq (char-before (point) (current-buffer)) nil))
 845   (Assert (eq (char-before (point-marker) (current-buffer)) nil))
 846   (Assert (eq (char-after) nil))
 847   (Assert (eq (char-after (point)) nil))
 848   (Assert (eq (char-after (point-marker)) nil))
 849   (Assert (eq (char-after (point) (current-buffer)) nil))
 850   (Assert (eq (char-after (point-marker) (current-buffer)) nil))
 851   (Assert (eq (preceding-char) 0))
 852   (Assert (eq (preceding-char (current-buffer)) 0))
 853   (Assert (eq (following-char) 0))
 854   (Assert (eq (following-char (current-buffer)) 0))
 855   (insert "foobar")
 856   (Assert (eq (char-before) ?r))
 857   (Assert (eq (char-after) nil))
 858   (Assert (eq (preceding-char) ?r))
 859   (Assert (eq (following-char) 0))
 860   (goto-char (point-min))
 861   (Assert (eq (char-before) nil))
 862   (Assert (eq (char-after) ?f))
 863   (Assert (eq (preceding-char) 0))
 864   (Assert (eq (following-char) ?f))
 865   )
 866
 867 ;;-----------------------------------------------------
 868 ;; Test plist manipulation functions.
 869 ;;-----------------------------------------------------
 870 (let ((sym (make-symbol "test-symbol")))
 871   (Assert (eq t (get* sym t t)))
 872   (Assert (eq t (get  sym t t)))
 873   (Assert (eq t (getf nil t t)))
 874   (Assert (eq t (plist-get nil t t)))
 875   (put sym 'bar 'baz)
 876   (Assert (eq 'baz (get sym 'bar)))
 877   (Assert (eq 'baz (getf '(bar baz) 'bar)))
 878   (Assert (eq 'baz (getf (symbol-plist sym) 'bar)))
 879   (Assert (eq 2 (getf '(1 2) 1)))
 880   (Assert (eq 4 (put sym 3 4)))
 881   (Assert (eq 4 (get sym 3)))
 882   (Assert (eq t (remprop sym 3)))
 883   (Assert (eq nil (remprop sym 3)))
 884   (Assert (eq 5 (get sym 3 5)))
 885   )
 886
 887 (loop for obj in
 888   (list (make-symbol "test-symbol")
 889         "test-string"
 890         (make-extent nil nil nil)
 891         (make-face 'test-face))
 892   do
 893   (Assert (eq 2 (get obj ?1 2)))
 894   (Assert (eq 4 (put obj ?3 4)))
 895   (Assert (eq 4 (get obj ?3)))
 896   (when (or (stringp obj) (symbolp obj))
 897     (Assert (equal '(?3 4) (object-plist obj))))
 898   (Assert (eq t (remprop obj ?3)))
 899   (when (or (stringp obj) (symbolp obj))
 900     (Assert (eq '() (object-plist obj))))
 901   (Assert (eq nil (remprop obj ?3)))
 902   (when (or (stringp obj) (symbolp obj))
 903     (Assert (eq '() (object-plist obj))))
 904   (Assert (eq 5 (get obj ?3 5)))
 905   )
 906
 907 (Check-Error-Message
 908  error "Object type has no properties"
 909  (get 2 'property))
 910
 911 (Check-Error-Message
 912  error "Object type has no settable properties"
 913  (put (current-buffer) 'property 'value))
 914
 915 (Check-Error-Message
 916  error "Object type has no removable properties"
 917  (remprop ?3 'property))
 918
 919 (Check-Error-Message
 920  error "Object type has no properties"
 921  (object-plist (symbol-function 'car)))
 922
 923 (Check-Error-Message
 924  error "Can't remove property from object"
 925  (remprop (make-extent nil nil nil) 'detachable))
 926
 927 ;;-----------------------------------------------------
 928 ;; Test subseq
 929 ;;-----------------------------------------------------
 930 (Assert (equal (subseq nil 0) nil))
 931 (Assert (equal (subseq [1 2 3] 0) [1 2 3]))
 932 (Assert (equal (subseq [1 2 3] 1 -1) [2]))
 933 (Assert (equal (subseq "123" 0) "123"))
 934 (Assert (equal (subseq "1234" -3 -1) "23"))
 935 (Assert (equal (subseq #*0011 0) #*0011))
 936 (Assert (equal (subseq #*0011 -3 3) #*01))
 937 (Assert (equal (subseq '(1 2 3) 0) '(1 2 3)))
 938 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)))
 939
 940 (Check-Error 'wrong-type-argument (subseq 3 2))
 941 (Check-Error 'args-out-of-range (subseq [1 2 3] -42))
 942 (Check-Error 'args-out-of-range (subseq [1 2 3] 0 42))
 943
 944 ;;-----------------------------------------------------
 945 ;; Time-related tests
 946 ;;-----------------------------------------------------
 947 (Assert (= (length (current-time-string)) 24))