X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0d7b2c96d388f5a9b539df3cb7f4ef115e7010b7..af013e0d4a76f0a2fd4a0e76912e8e49ae86ec2e:/test/automated/cl-lib-tests.el

diff --git a/test/automated/cl-lib-tests.el b/test/automated/cl-lib-tests.el
index e4c6e914ee..1bdc6d7ca0 100644
--- a/test/automated/cl-lib-tests.el
+++ b/test/automated/cl-lib-tests.el
@@ -1,6 +1,6 @@
-;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el
+;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el  -*- lexical-binding:t -*-
 
-;; Copyright (C) 2013-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
 
 ;; This file is part of GNU Emacs.
 
@@ -204,7 +204,10 @@
                     :b :a :a 42)
            '(42 :a))))
 
-(cl-defstruct mystruct (abc :readonly t) def)
+(cl-defstruct (mystruct
+               (:constructor cl-lib--con-1 (&aux (abc 1)))
+               (:constructor cl-lib--con-2 (&optional def)))
+  (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))
@@ -213,8 +216,17 @@
     (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 (equal (cl-struct-slot-info 'mystruct)
-                   '((cl-tag-slot) (abc :readonly t) (def))))))
+    (should (pcase (cl-struct-slot-info 'mystruct)
+              (`((cl-tag-slot) (abc 5 :readonly t)
+                 (def . ,(or `nil `(nil))))
+               t)))))
+
+(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))
@@ -223,13 +235,233 @@
     (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 (cl-digit-char-p ?3))
-  (should (cl-digit-char-p ?a 11))
+  (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 (cl-digit-char-p ?w 36))
-  (should-error (cl-digit-char-p ?a 37))
-  (should-error (cl-digit-char-p ?a 1)))
+  (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"))
@@ -245,4 +477,14 @@
 (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