diff options
Diffstat (limited to 'test/automated/cl-lib-tests.el')
| -rw-r--r-- | test/automated/cl-lib-tests.el | 496 |
1 files changed, 0 insertions, 496 deletions
diff --git a/test/automated/cl-lib-tests.el b/test/automated/cl-lib-tests.el deleted file mode 100644 index cbaf70fc4bb..00000000000 --- a/test/automated/cl-lib-tests.el +++ /dev/null @@ -1,496 +0,0 @@ -;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el -*- lexical-binding:t -*- - -;; Copyright (C) 2013-2016 Free Software Foundation, Inc. - -;; This file is part of GNU Emacs. - -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `http://www.gnu.org/licenses/'. - -;;; Commentary: - -;; Extracted from ert-tests.el, back when ert used to reimplement some -;; cl functions. - -;;; Code: - -(require 'cl-lib) -(require 'ert) - -(ert-deftest cl-lib-test-remprop () - (let ((x (cl-gensym))) - (should (equal (symbol-plist x) '())) - ;; Remove nonexistent property on empty plist. - (cl-remprop x 'b) - (should (equal (symbol-plist x) '())) - (put x 'a 1) - (should (equal (symbol-plist x) '(a 1))) - ;; Remove nonexistent property on nonempty plist. - (cl-remprop x 'b) - (should (equal (symbol-plist x) '(a 1))) - (put x 'b 2) - (put x 'c 3) - (put x 'd 4) - (should (equal (symbol-plist x) '(a 1 b 2 c 3 d 4))) - ;; Remove property that is neither first nor last. - (cl-remprop x 'c) - (should (equal (symbol-plist x) '(a 1 b 2 d 4))) - ;; Remove last property from a plist of length >1. - (cl-remprop x 'd) - (should (equal (symbol-plist x) '(a 1 b 2))) - ;; Remove first property from a plist of length >1. - (cl-remprop x 'a) - (should (equal (symbol-plist x) '(b 2))) - ;; Remove property when there is only one. - (cl-remprop x 'b) - (should (equal (symbol-plist x) '())))) - -(ert-deftest cl-lib-test-remove-if-not () - (let ((list (list 'a 'b 'c 'd)) - (i 0)) - (let ((result (cl-remove-if-not (lambda (x) - (should (eql x (nth i list))) - (cl-incf i) - (member i '(2 3))) - list))) - (should (equal i 4)) - (should (equal result '(b c))) - (should (equal list '(a b c d))))) - (should (equal '() - (cl-remove-if-not (lambda (_x) (should nil)) '())))) - -(ert-deftest cl-lib-test-remove () - (let ((list (list 'a 'b 'c 'd)) - (key-index 0) - (test-index 0)) - (let ((result - (cl-remove 'foo list - :key (lambda (x) - (should (eql x (nth key-index list))) - (prog1 - (list key-index x) - (cl-incf key-index))) - :test - (lambda (a b) - (should (eql a 'foo)) - (should (equal b (list test-index - (nth test-index list)))) - (cl-incf test-index) - (member test-index '(2 3)))))) - (should (equal key-index 4)) - (should (equal test-index 4)) - (should (equal result '(a d))) - (should (equal list '(a b c d))))) - (let ((x (cons nil nil)) - (y (cons nil nil))) - (should (equal (cl-remove x (list x y)) - ;; or (list x), since we use `equal' -- the - ;; important thing is that only one element got - ;; removed, this proves that the default test is - ;; `eql', not `equal' - (list y))))) - - -(ert-deftest cl-lib-test-set-functions () - (let ((c1 (cons nil nil)) - (c2 (cons nil nil)) - (sym (make-symbol "a"))) - (let ((e '()) - (a (list 'a 'b sym nil "" "x" c1 c2)) - (b (list c1 'y 'b sym 'x))) - (should (equal (cl-set-difference e e) e)) - (should (equal (cl-set-difference a e) a)) - (should (equal (cl-set-difference e a) e)) - (should (equal (cl-set-difference a a) e)) - (should (equal (cl-set-difference b e) b)) - (should (equal (cl-set-difference e b) e)) - (should (equal (cl-set-difference b b) e)) - ;; Note: this test (and others) is sensitive to the order of the - ;; result, which is not documented. - (should (equal (cl-set-difference a b) (list 'a nil "" "x" c2))) - (should (equal (cl-set-difference b a) (list 'y 'x))) - - ;; We aren't testing whether this is really using `eq' rather than `eql'. - (should (equal (cl-set-difference e e :test 'eq) e)) - (should (equal (cl-set-difference a e :test 'eq) a)) - (should (equal (cl-set-difference e a :test 'eq) e)) - (should (equal (cl-set-difference a a :test 'eq) e)) - (should (equal (cl-set-difference b e :test 'eq) b)) - (should (equal (cl-set-difference e b :test 'eq) e)) - (should (equal (cl-set-difference b b :test 'eq) e)) - (should (equal (cl-set-difference a b :test 'eq) (list 'a nil "" "x" c2))) - (should (equal (cl-set-difference b a :test 'eq) (list 'y 'x))) - - (should (equal (cl-union e e) e)) - (should (equal (cl-union a e) a)) - (should (equal (cl-union e a) a)) - (should (equal (cl-union a a) a)) - (should (equal (cl-union b e) b)) - (should (equal (cl-union e b) b)) - (should (equal (cl-union b b) b)) - (should (equal (cl-union a b) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) - - (should (equal (cl-union b a) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) - - (should (equal (cl-intersection e e) e)) - (should (equal (cl-intersection a e) e)) - (should (equal (cl-intersection e a) e)) - (should (equal (cl-intersection a a) a)) - (should (equal (cl-intersection b e) e)) - (should (equal (cl-intersection e b) e)) - (should (equal (cl-intersection b b) b)) - (should (equal (cl-intersection a b) (list sym 'b c1))) - (should (equal (cl-intersection b a) (list sym 'b c1)))))) - -(ert-deftest cl-lib-test-gensym () - ;; Since the expansion of `should' calls `cl-gensym' and thus has a - ;; side-effect on `cl--gensym-counter', we have to make sure all - ;; macros in our test body are expanded before we rebind - ;; `cl--gensym-counter' and run the body. Otherwise, the test would - ;; fail if run interpreted. - (let ((body (byte-compile - '(lambda () - (should (equal (symbol-name (cl-gensym)) "G0")) - (should (equal (symbol-name (cl-gensym)) "G1")) - (should (equal (symbol-name (cl-gensym)) "G2")) - (should (equal (symbol-name (cl-gensym "foo")) "foo3")) - (should (equal (symbol-name (cl-gensym "bar")) "bar4")) - (should (equal cl--gensym-counter 5)))))) - (let ((cl--gensym-counter 0)) - (funcall body)))) - -(ert-deftest cl-lib-test-coerce-to-vector () - (let* ((a (vector)) - (b (vector 1 a 3)) - (c (list)) - (d (list b a))) - (should (eql (cl-coerce a 'vector) a)) - (should (eql (cl-coerce b 'vector) b)) - (should (equal (cl-coerce c 'vector) (vector))) - (should (equal (cl-coerce d 'vector) (vector b a))))) - -(ert-deftest cl-lib-test-string-position () - (should (eql (cl-position ?x "") nil)) - (should (eql (cl-position ?a "abc") 0)) - (should (eql (cl-position ?b "abc") 1)) - (should (eql (cl-position ?c "abc") 2)) - (should (eql (cl-position ?d "abc") nil)) - (should (eql (cl-position ?A "abc") nil))) - -(ert-deftest cl-lib-test-mismatch () - (should (eql (cl-mismatch "" "") nil)) - (should (eql (cl-mismatch "" "a") 0)) - (should (eql (cl-mismatch "a" "a") nil)) - (should (eql (cl-mismatch "ab" "a") 1)) - (should (eql (cl-mismatch "Aa" "aA") 0)) - (should (eql (cl-mismatch '(a b c) '(a b d)) 2))) - -(ert-deftest cl-lib-test-loop () - (should (eql (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) - -(ert-deftest cl-lib-keyword-names-versus-values () - (should (equal - (funcall (cl-function (lambda (&key a b) (list a b))) - :b :a :a 42) - '(42 :a)))) - -(cl-defstruct (mystruct - (:constructor cl-lib--con-1 (&aux (abc 1))) - (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) - "General docstring." - (abc 5 :readonly t) (def nil)) -(ert-deftest cl-lib-struct-accessors () - (let ((x (make-mystruct :abc 1 :def 2))) - (should (eql (cl-struct-slot-value 'mystruct 'abc x) 1)) - (should (eql (cl-struct-slot-value 'mystruct 'def x) 2)) - (setf (cl-struct-slot-value 'mystruct 'def x) -1) - (should (eql (cl-struct-slot-value 'mystruct 'def x) -1)) - (should (eql (cl-struct-slot-offset 'mystruct 'abc) 1)) - (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) - (should (pcase (cl-struct-slot-info 'mystruct) - (`((cl-tag-slot) (abc 5 :readonly t) - (def . ,(or `nil `(nil)))) - t))))) -(ert-deftest cl-lib-struct-constructors () - (should (string-match "\\`Constructor docstring." - (documentation 'cl-lib--con-2 t))) - (should (mystruct-p (cl-lib--con-1))) - (should (mystruct-p (cl-lib--con-2)))) - -(ert-deftest cl-lib-arglist-performance () - ;; An `&aux' should not cause lambda's arglist to be turned into an &rest - ;; that's parsed by hand. - (should (equal () (help-function-arglist 'cl-lib--con-1))) - (should (pcase (help-function-arglist 'cl-lib--con-2) - (`(&optional ,_) t)))) - -(ert-deftest cl-the () - (should (eql (cl-the integer 42) 42)) - (should-error (cl-the integer "abc")) - (let ((side-effect 0)) - (should (= (cl-the integer (cl-incf side-effect)) 1)) - (should (= side-effect 1)))) - -(ert-deftest cl-lib-test-plusp () - (should-not (cl-plusp -1.0e+INF)) - (should-not (cl-plusp -1.5e2)) - (should-not (cl-plusp -3.14)) - (should-not (cl-plusp -1)) - (should-not (cl-plusp -0.0)) - (should-not (cl-plusp 0)) - (should-not (cl-plusp 0.0)) - (should-not (cl-plusp -0.0e+NaN)) - (should-not (cl-plusp 0.0e+NaN)) - (should (cl-plusp 1)) - (should (cl-plusp 3.14)) - (should (cl-plusp 1.5e2)) - (should (cl-plusp 1.0e+INF)) - (should-error (cl-plusp "42") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-minusp () - (should (cl-minusp -1.0e+INF)) - (should (cl-minusp -1.5e2)) - (should (cl-minusp -3.14)) - (should (cl-minusp -1)) - (should-not (cl-minusp -0.0)) - (should-not (cl-minusp 0)) - (should-not (cl-minusp 0.0)) - (should-not (cl-minusp -0.0e+NaN)) - (should-not (cl-minusp 0.0e+NaN)) - (should-not (cl-minusp 1)) - (should-not (cl-minusp 3.14)) - (should-not (cl-minusp 1.5e2)) - (should-not (cl-minusp 1.0e+INF)) - (should-error (cl-minusp "-42") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-oddp () - (should (cl-oddp -3)) - (should (cl-oddp 3)) - (should-not (cl-oddp -2)) - (should-not (cl-oddp 0)) - (should-not (cl-oddp 2)) - (should-error (cl-oddp 3.0e+NaN) :type 'wrong-type-argument) - (should-error (cl-oddp 3.0) :type 'wrong-type-argument) - (should-error (cl-oddp "3") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-evenp () - (should (cl-evenp -2)) - (should (cl-evenp 0)) - (should (cl-evenp 2)) - (should-not (cl-evenp -3)) - (should-not (cl-evenp 3)) - (should-error (cl-evenp 2.0e+NaN) :type 'wrong-type-argument) - (should-error (cl-evenp 2.0) :type 'wrong-type-argument) - (should-error (cl-evenp "2") :type 'wrong-type-argument)) - -(ert-deftest cl-digit-char-p () - (should (eql 3 (cl-digit-char-p ?3))) - (should (eql 10 (cl-digit-char-p ?a 11))) - (should (eql 10 (cl-digit-char-p ?A 11))) - (should-not (cl-digit-char-p ?a)) - (should (eql 32 (cl-digit-char-p ?w 36))) - (should-error (cl-digit-char-p ?a 37) :type 'args-out-of-range) - (should-error (cl-digit-char-p ?a 1) :type 'args-out-of-range)) - -(ert-deftest cl-lib-test-first () - (should (null (cl-first '()))) - (should (= 4 (cl-first '(4)))) - (should (= 4 (cl-first '(4 2)))) - (should-error (cl-first "42") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-second () - (should (null (cl-second '()))) - (should (null (cl-second '(4)))) - (should (= 2 (cl-second '(1 2)))) - (should (= 2 (cl-second '(1 2 3)))) - (should-error (cl-second "1 2 3") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-third () - (should (null (cl-third '()))) - (should (null (cl-third '(1 2)))) - (should (= 3 (cl-third '(1 2 3)))) - (should (= 3 (cl-third '(1 2 3 4)))) - (should-error (cl-third "123") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-fourth () - (should (null (cl-fourth '()))) - (should (null (cl-fourth '(1 2 3)))) - (should (= 4 (cl-fourth '(1 2 3 4)))) - (should (= 4 (cl-fourth '(1 2 3 4 5)))) - (should-error (cl-fourth "1234") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-fifth () - (should (null (cl-fifth '()))) - (should (null (cl-fifth '(1 2 3 4)))) - (should (= 5 (cl-fifth '(1 2 3 4 5)))) - (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) - (should-error (cl-fifth "12345") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-fifth () - (should (null (cl-fifth '()))) - (should (null (cl-fifth '(1 2 3 4)))) - (should (= 5 (cl-fifth '(1 2 3 4 5)))) - (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) - (should-error (cl-fifth "12345") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-sixth () - (should (null (cl-sixth '()))) - (should (null (cl-sixth '(1 2 3 4 5)))) - (should (= 6 (cl-sixth '(1 2 3 4 5 6)))) - (should (= 6 (cl-sixth '(1 2 3 4 5 6 7)))) - (should-error (cl-sixth "123456") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-seventh () - (should (null (cl-seventh '()))) - (should (null (cl-seventh '(1 2 3 4 5 6)))) - (should (= 7 (cl-seventh '(1 2 3 4 5 6 7)))) - (should (= 7 (cl-seventh '(1 2 3 4 5 6 7 8)))) - (should-error (cl-seventh "1234567") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-eighth () - (should (null (cl-eighth '()))) - (should (null (cl-eighth '(1 2 3 4 5 6 7)))) - (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8)))) - (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8 9)))) - (should-error (cl-eighth "12345678") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-ninth () - (should (null (cl-ninth '()))) - (should (null (cl-ninth '(1 2 3 4 5 6 7 8)))) - (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9)))) - (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9 10)))) - (should-error (cl-ninth "123456789") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-tenth () - (should (null (cl-tenth '()))) - (should (null (cl-tenth '(1 2 3 4 5 6 7 8 9)))) - (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10)))) - (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10 11)))) - (should-error (cl-tenth "1234567890") :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-endp () - (should (cl-endp '())) - (should-not (cl-endp '(1))) - (should-error (cl-endp 1) :type 'wrong-type-argument) - (should-error (cl-endp [1]) :type 'wrong-type-argument)) - -(ert-deftest cl-lib-test-nth-value () - (let ((vals (cl-values 2 3))) - (should (= (cl-nth-value 0 vals) 2)) - (should (= (cl-nth-value 1 vals) 3)) - (should (null (cl-nth-value 2 vals))) - (should-error (cl-nth-value 0.0 vals) :type 'wrong-type-argument))) - -(ert-deftest cl-lib-nth-value-test-multiple-values () - "While CL multiple values are an alias to list, these won't work." - :expected-result :failed - (should (eq (cl-nth-value 0 '(2 3)) '(2 3))) - (should (= (cl-nth-value 0 1) 1)) - (should (null (cl-nth-value 1 1))) - (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) - (should (string= (cl-nth-value 0 "only lists") "only lists"))) - -(ert-deftest cl-test-caaar () - (should (null (cl-caaar '()))) - (should (null (cl-caaar '(() (2))))) - (should (null (cl-caaar '((() (2)) (a b))))) - (should-error (cl-caaar '(1 2)) :type 'wrong-type-argument) - (should-error (cl-caaar '((1 2))) :type 'wrong-type-argument) - (should (= 1 (cl-caaar '(((1 2) (3 4)))))) - (should (null (cl-caaar '((() (3 4))))))) - -(ert-deftest cl-test-caadr () - (should (null (cl-caadr '()))) - (should (null (cl-caadr '(1)))) - (should-error (cl-caadr '(1 2)) :type 'wrong-type-argument) - (should (= 2 (cl-caadr '(1 (2 3))))) - (should (equal '((2) (3)) (cl-caadr '((1) (((2) (3))) (4)))))) - -(ert-deftest cl-test-ldiff () - (let ((l '(1 2 3))) - (should (null (cl-ldiff '() '()))) - (should (null (cl-ldiff '() l))) - (should (null (cl-ldiff l l))) - (should (equal l (cl-ldiff l '()))) - ;; must be part of the list - (should (equal l (cl-ldiff l '(2 3)))) - (should (equal '(1) (cl-ldiff l (nthcdr 1 l)))) - ;; should return a copy - (should-not (eq (cl-ldiff l '()) l)))) - -(ert-deftest cl-lib-adjoin-test () - (let ((nums '(1 2)) - (myfn-p '=)) - ;; add non-existing item to the front - (should (equal '(3 1 2) (cl-adjoin 3 nums))) - ;; just add - don't copy rest - (should (eq nums (cdr (cl-adjoin 3 nums)))) - ;; add only when not already there - (should (eq nums (cl-adjoin 2 nums))) - (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2))))) - ;; default test function is eql - (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums))) - ;; own :test function - returns true if match - (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test nil))) ;defaults to eql - (should (eq nums (cl-adjoin 2 nums :test myfn-p))) ;match - (should (equal '(3 1 2) (cl-adjoin 3 nums :test myfn-p))) ;no match - ;; own :test-not function - returns false if match - (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test-not nil))) ;defaults to eql - (should (equal '(2 2) (cl-adjoin 2 '(2) :test-not myfn-p))) ; no match - (should (eq nums (cl-adjoin 2 nums :test-not myfn-p))) ; 1 matches - (should (eq nums (cl-adjoin 3 nums :test-not myfn-p))) ; 1 and 2 matches - - ;; according to CLtL2 passing both :test and :test-not should signal error - ;;(should-error (cl-adjoin 3 nums :test 'myfn-p :test-not myfn-p)) - - ;; own :key fn - (should (eq nums (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (1+ x) x))))) - (should (equal '(3 1 2) (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (+ 2 x) x))))) - - ;; convert using :key, then compare with :test - (should (eq nums (cl-adjoin 1 nums :key 'int-to-string :test 'string=))) - (should (equal '(3 1 2) (cl-adjoin 3 nums :key 'int-to-string :test 'string=))) - (should-error (cl-adjoin 3 nums :key 'int-to-string :test myfn-p) - :type 'wrong-type-argument) - - ;; convert using :key, then compare with :test-not - (should (eq nums (cl-adjoin 3 nums :key 'int-to-string :test-not 'string=))) - (should (equal '(1 1) (cl-adjoin 1 '(1) :key 'int-to-string :test-not 'string=))) - (should-error (cl-adjoin 1 nums :key 'int-to-string :test-not myfn-p) - :type 'wrong-type-argument))) - -(ert-deftest cl-parse-integer () - (should-error (cl-parse-integer "abc")) - (should (null (cl-parse-integer "abc" :junk-allowed t))) - (should (null (cl-parse-integer "" :junk-allowed t))) - (should (= 342391 (cl-parse-integer "0123456789" :radix 8 :junk-allowed t))) - (should-error (cl-parse-integer "0123456789" :radix 8)) - (should (= -239 (cl-parse-integer "-efz" :radix 16 :junk-allowed t))) - (should-error (cl-parse-integer "efz" :radix 16)) - (should (= 239 (cl-parse-integer "zzef" :radix 16 :start 2))) - (should (= -123 (cl-parse-integer " -123 ")))) - -(ert-deftest cl-loop-destructuring-with () - (should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) - -(ert-deftest cl-flet-test () - (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5))) - -(ert-deftest cl-lib-test-typep () - (cl-deftype cl-lib-test-type (&optional x) `(member ,x)) - ;; Make sure we correctly implement the rule that deftype's optional args - ;; default to `*' rather than to nil. - (should (cl-typep '* 'cl-lib-test-type)) - (should-not (cl-typep 1 'cl-lib-test-type))) - -;;; cl-lib.el ends here |