Mercurial > hg > xemacs-beta

comparison tests/automated/lisp-tests.el @ 5473:ac37a5f7e5be

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Thu, 17 Mar 2011 23:42:59 +0100
parents 00e79bbbe48f d967d96ca043
children f2881cb841b4
comparison
equal deleted inserted replaced
5472:e79980ee5efe 5473:ac37a5f7e5be
792 (Check-Error wrong-number-of-arguments (,fun)) 792 (Check-Error wrong-number-of-arguments (,fun))
793 (Check-Error wrong-number-of-arguments (,fun nil)) 793 (Check-Error wrong-number-of-arguments (,fun nil))
794 (Check-Error (malformed-list wrong-type-argument) (,fun nil 1)) 794 (Check-Error (malformed-list wrong-type-argument) (,fun nil 1))
795 ,@(loop for n in '(1 2 2000) 795 ,@(loop for n in '(1 2 2000)
796 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) 796 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n))))))
797 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))) 797 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))
798 798 (test-old-funs (&rest funs)
799 `(when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
800 ,@(loop for fun in funs collect `(test-fun ,fun)))))
799 (test-funs member* member memq 801 (test-funs member* member memq
800 assoc* assoc assq 802 assoc* assoc assq
801 rassoc* rassoc rassq 803 rassoc* rassoc rassq
802 delete* delete delq 804 delete* delete delq
803 remove* remove remq 805 remove* remove remq
804 old-member old-memq 806 remassoc remassq remrassoc remrassq)
805 old-assoc old-assq 807 (test-old-funs old-member old-memq old-assoc old-assq old-rassoc old-rassq
806 old-rassoc old-rassq 808 old-delete old-delq))
807 old-delete old-delq
808 remassoc remassq remrassoc remrassq))
809 809
810 (let ((x '((1 . 2) 3 (4 . 5)))) 810 (let ((x '((1 . 2) 3 (4 . 5))))
811 (Assert (eq (assoc 1 x) (car x))) 811 (Assert (eq (assoc 1 x) (car x)))
812 (Assert (eq (assq 1 x) (car x))) 812 (Assert (eq (assq 1 x) (car x)))
813 (Assert (eq (rassoc 1 x) nil)) 813 (Assert (eq (rassoc 1 x) nil))
887 887
888 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a))))) 888 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a)))))
889 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a))))) 889 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a)))))
890 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a))))) 890 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a)))))
891 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a))))) 891 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a)))))
892
893 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) 892 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
894 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) 893 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
895 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
896 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
897
898 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) 894 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
899 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) 895 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
900 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) 896 (when (and (fboundp 'old-eq) (subrp (symbol-function 'old-eq)))
901 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) 897 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5))))))
902 ) 898 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a)))))
903 899 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))
904 900 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5))))))))
905 901
906 (flet ((a () (list '("1" . "2") "3" '("4" . "5")))) 902 (flet ((a () (list '("1" . "2") "3" '("4" . "5"))))
907 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) 903 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5"))))))
908 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a))))) 904 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a)))))
909 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a))))) 905 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a)))))
1334 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4))) 1330 (Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)))
1335 1331
1336 (Check-Error wrong-type-argument (subseq 3 2)) 1332 (Check-Error wrong-type-argument (subseq 3 2))
1337 (Check-Error args-out-of-range (subseq [1 2 3] -42)) 1333 (Check-Error args-out-of-range (subseq [1 2 3] -42))
1338 (Check-Error args-out-of-range (subseq [1 2 3] 0 42)) 1334 (Check-Error args-out-of-range (subseq [1 2 3] 0 42))
1335
1336 (let ((string "hi there"))
1337 (Assert (equal (substring-no-properties "123" 0) "123"))
1338 (Assert (equal (substring-no-properties "1234" -3 -1) "23"))
1339 (Assert (equal (substring-no-properties "hi there" 0) "hi there"))
1340 (put-text-property 0 (length string) 'foo 'bar string)
1341 (Assert (eq 'bar (get-text-property 0 'foo string)))
1342 (Assert (not
1343 (get-text-property 0 'foo (substring-no-properties "hi there" 0))))
1344 (Check-Error wrong-type-argument (substring-no-properties nil 4))
1345 (Check-Error wrong-type-argument (substring-no-properties "hi there" pi))
1346 (Check-Error wrong-type-argument (substring-no-properties "hi there" 0.0)))
1339 1347
1340 ;;----------------------------------------------------- 1348 ;;-----------------------------------------------------
1341 ;; Time-related tests 1349 ;; Time-related tests
1342 ;;----------------------------------------------------- 1350 ;;-----------------------------------------------------
1343 (Assert (= (length (current-time-string)) 24)) 1351 (Assert (= (length (current-time-string)) 24))