summaryrefslogtreecommitdiff
path: root/test/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'test/lisp/emacs-lisp')
-rw-r--r--test/lisp/emacs-lisp/backtrace-tests.el6
-rw-r--r--test/lisp/emacs-lisp/bytecomp-tests.el364
-rw-r--r--test/lisp/emacs-lisp/cconv-tests.el25
-rw-r--r--test/lisp/emacs-lisp/cl-lib-tests.el9
-rw-r--r--test/lisp/emacs-lisp/cl-macs-tests.el26
-rw-r--r--test/lisp/emacs-lisp/cl-print-tests.el7
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el1
-rw-r--r--test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el10
-rw-r--r--test/lisp/emacs-lisp/ert-tests.el28
-rw-r--r--test/lisp/emacs-lisp/lisp-mode-tests.el23
-rw-r--r--test/lisp/emacs-lisp/macroexp-tests.el16
-rw-r--r--test/lisp/emacs-lisp/map-tests.el59
-rw-r--r--test/lisp/emacs-lisp/multisession-tests.el2
-rw-r--r--test/lisp/emacs-lisp/nadvice-tests.el38
-rw-r--r--test/lisp/emacs-lisp/package-tests.el11
-rw-r--r--test/lisp/emacs-lisp/pp-tests.el4
-rw-r--r--test/lisp/emacs-lisp/rx-tests.el74
-rw-r--r--test/lisp/emacs-lisp/shortdoc-tests.el43
-rw-r--r--test/lisp/emacs-lisp/subr-x-tests.el17
19 files changed, 688 insertions, 75 deletions
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el
index 794488edae8..e5899446ee4 100644
--- a/test/lisp/emacs-lisp/backtrace-tests.el
+++ b/test/lisp/emacs-lisp/backtrace-tests.el
@@ -226,6 +226,9 @@
"Forms in backtrace frames can be on a single line or on multiple lines."
(ert-with-test-buffer (:name "single-multi-line")
(let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure.
+ ;; Make the form long enough so `number' should not
+ ;; appear on the first line once pretty-printed.
+ (interactive (region-beginning))
(let ((number (1+ x)))
(+ x number))))
(header-string "Test header: ")
@@ -280,7 +283,8 @@ line contains the strings \"lambda\" and \"number\"."
;; Verify that the form is now back on one line,
;; and that point is at the same place.
(should (string= (backtrace-tests--get-substring
- (- (point) 6) (point)) "number"))
+ (- (point) 6) (point))
+ "number"))
(should-not (= (point) (pos-bol)))
(should (string= (backtrace-tests--get-substring
(pos-bol) (1+ (pos-eol)))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 7ae10cdea73..593fd117685 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -704,6 +704,87 @@ inner loops respectively."
(let ((bytecomp-tests--xx 1))
(set (make-local-variable 'bytecomp-tests--xx) 2)
bytecomp-tests--xx)
+
+ ;; Check for-effect optimisation of `condition-case' body form.
+ ;; With `condition-case' in for-effect context:
+ (let ((x (bytecomp-test-identity ?A))
+ (r nil))
+ (condition-case e
+ (characterp x) ; value (:success, var)
+ (error (setq r 'bad))
+ (:success (setq r (list 'good e))))
+ r)
+ (let ((x (bytecomp-test-identity ?B))
+ (r nil))
+ (condition-case nil
+ (characterp x) ; for-effect (:success, no var)
+ (error (setq r 'bad))
+ (:success (setq r 'good)))
+ r)
+ (let ((x (bytecomp-test-identity ?C))
+ (r nil))
+ (condition-case e
+ (characterp x) ; for-effect (no :success, var)
+ (error (setq r (list 'bad e))))
+ r)
+ (let ((x (bytecomp-test-identity ?D))
+ (r nil))
+ (condition-case nil
+ (characterp x) ; for-effect (no :success, no var)
+ (error (setq r 'bad)))
+ r)
+ ;; With `condition-case' in value context:
+ (let ((x (bytecomp-test-identity ?E)))
+ (condition-case e
+ (characterp x) ; for-effect (:success, var)
+ (error (list 'bad e))
+ (:success (list 'good e))))
+ (let ((x (bytecomp-test-identity ?F)))
+ (condition-case nil
+ (characterp x) ; for-effect (:success, no var)
+ (error 'bad)
+ (:success 'good)))
+ (let ((x (bytecomp-test-identity ?G)))
+ (condition-case e
+ (characterp x) ; value (no :success, var)
+ (error (list 'bad e))))
+ (let ((x (bytecomp-test-identity ?H)))
+ (condition-case nil
+ (characterp x) ; value (no :success, no var)
+ (error 'bad)))
+
+ (condition-case nil
+ (bytecomp-test-identity 3)
+ (error 'bad)
+ (:success)) ; empty handler
+
+ ;; `cond' miscompilation bug
+ (let ((fn (lambda (x)
+ (let ((y nil))
+ (cond ((progn (setq x (1+ x)) (> x 10)) (setq y 'a))
+ ((eq x 1) (setq y 'b))
+ ((eq x 2) (setq y 'c)))
+ (list x y)))))
+ (mapcar fn (bytecomp-test-identity '(0 1 2 3 10 11))))
+
+ ;; `nconc' nil arg elimination
+ (nconc (list 1 2 3 4) nil)
+ (nconc (list 1 2 3 4) nil nil)
+ (let ((x (cons 1 (cons 2 (cons 3 4)))))
+ (nconc x nil))
+ (let ((x (cons 1 (cons 2 (cons 3 4)))))
+ (nconc x nil nil))
+ (let ((x (cons 1 (cons 2 (cons 3 4)))))
+ (nconc nil x nil (list 5 6) nil))
+
+ ;; (+ 0 -0.0) etc
+ (let ((x (bytecomp-test-identity -0.0)))
+ (list x (+ x) (+ 0 x) (+ x 0) (+ 1 2 -3 x) (+ 0 x 0)))
+
+ ;; Unary comparisons: keep side-effect, return t
+ (let ((x 0))
+ (list (= (setq x 1))
+ x))
)
"List of expressions for cross-testing interpreted and compiled code.")
@@ -833,13 +914,28 @@ byte-compiled. Run with dynamic binding."
;; Should not warn that mt--test2 is not known to be defined.
(should-not (re-search-forward "my--test2" nil t))))
-(defmacro bytecomp--with-warning-test (re-warning &rest form)
+(defun bytecomp--with-warning-test (re-warning form)
(declare (indent 1))
- `(with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create "*Compile-Log*")
(let ((inhibit-read-only t)) (erase-buffer))
- (byte-compile ,@form)
- (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
- (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning))))))
+ (let ((text-quoting-style 'grave)
+ (macroexp--warned ; oh dear
+ (make-hash-table :test #'equal :weakness 'key)))
+ (ert-info ((prin1-to-string form) :prefix "form: ")
+ (byte-compile form)
+ (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
+ (should (re-search-forward
+ (string-replace " " "[ \n]+" re-warning))))))))
+
+(ert-deftest bytecomp-warn--ignore ()
+ (bytecomp--with-warning-test "unused"
+ '(lambda (y) 6))
+ (bytecomp--with-warning-test "\\`\\'" ;No warning!
+ '(lambda (y) (ignore y) 6))
+ (bytecomp--with-warning-test "assq"
+ '(lambda (x y) (progn (assq x y) 5)))
+ (bytecomp--with-warning-test "\\`\\'" ;No warning!
+ '(lambda (x y) (progn (ignore (assq x y)) 5))))
(ert-deftest bytecomp-warn-wrong-args ()
(bytecomp--with-warning-test "remq.*3.*2"
@@ -863,6 +959,66 @@ byte-compiled. Run with dynamic binding."
(bytecomp--with-warning-test "defvar.*foo.*wider than.*characters"
`(defvar foo t ,bytecomp-tests--docstring)))
+(ert-deftest bytecomp-warn-quoted-condition ()
+ (bytecomp--with-warning-test
+ "Warning: `condition-case' condition should not be quoted: 'arith-error"
+ '(condition-case nil
+ (abc)
+ ('arith-error "ugh")))
+ (bytecomp--with-warning-test
+ "Warning: `ignore-error' condition argument should not be quoted: 'error"
+ '(ignore-error 'error (abc))))
+
+(ert-deftest bytecomp-warn-dodgy-args-eq ()
+ (dolist (fn '(eq eql))
+ (cl-flet ((msg (type arg)
+ (format
+ "`%s' called with literal %s that may never match (arg %d)"
+ fn type arg)))
+ (bytecomp--with-warning-test (msg "list" 1) `(,fn '(a) 'x))
+ (bytecomp--with-warning-test (msg "string" 2) `(,fn 'x "a"))
+ (bytecomp--with-warning-test (msg "vector" 2) `(,fn 'x [a]))
+ (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x (lambda () 1)))
+ (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x #'(lambda () 1)))
+ (unless (eq fn 'eql)
+ (bytecomp--with-warning-test (msg "integer" 2) `(,fn 'x #x10000000000))
+ (bytecomp--with-warning-test (msg "float" 2) `(,fn 'x 1.0))))))
+
+(ert-deftest bytecomp-warn-dodgy-args-memq ()
+ (dolist (fn '(memq memql remq delq assq rassq))
+ (cl-labels
+ ((msg1 (type)
+ (format
+ "`%s' called with literal %s that may never match (arg 1)"
+ fn type))
+ (msg2 (type)
+ (format
+ "`%s' called with literal %s that may never match (element 2 of arg 2)"
+ fn type))
+ (lst (elt)
+ (cond ((eq fn 'assq) `((a . 1) (,elt . 2) (c . 3)))
+ ((eq fn 'rassq) `((1 . a) (2 . ,elt) (3 . c)))
+ (t `(a ,elt c))))
+ (form2 (elt)
+ `(,fn 'x ',(lst elt))))
+
+ (bytecomp--with-warning-test (msg1 "list") `(,fn '(a) '(x)))
+ (bytecomp--with-warning-test (msg1 "string") `(,fn "a" '(x)))
+ (bytecomp--with-warning-test (msg1 "vector") `(,fn [a] '(x)))
+ (bytecomp--with-warning-test (msg1 "function") `(,fn (lambda () 1) '(x)))
+ (bytecomp--with-warning-test (msg1 "function") `(,fn #'(lambda () 1) '(x)))
+ (unless (eq fn 'memql)
+ (bytecomp--with-warning-test (msg1 "integer") `(,fn #x10000000000 '(x)))
+ (bytecomp--with-warning-test (msg1 "float") `(,fn 1.0 '(x))))
+
+ (bytecomp--with-warning-test (msg2 "list") (form2 '(b)))
+ (bytecomp--with-warning-test (msg2 "list") (form2 ''b))
+ (bytecomp--with-warning-test (msg2 "string") (form2 "b"))
+ (bytecomp--with-warning-test (msg2 "vector") (form2 [b]))
+ (unless (eq fn 'memql)
+ (bytecomp--with-warning-test (msg2 "integer") (form2 #x10000000000))
+ (bytecomp--with-warning-test (msg2 "float") (form2 1.0))))))
+
(defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse)
`(ert-deftest ,(intern (format "bytecomp/%s" file)) ()
(with-current-buffer (get-buffer-create "*Compile-Log*")
@@ -1094,7 +1250,8 @@ byte-compiled. Run with dynamic binding."
literals (Bug#20852)."
(should (boundp 'lread--unescaped-character-literals))
(let ((byte-compile-error-on-warn t)
- (byte-compile-debug t))
+ (byte-compile-debug t)
+ (text-quoting-style 'grave))
(bytecomp-tests--with-temp-file source
(write-region "(list ?) ?( ?; ?\" ?[ ?])" nil source)
(bytecomp-tests--with-temp-file destination
@@ -1213,6 +1370,7 @@ literals (Bug#20852)."
(defun test-suppression (form suppress match)
(let ((lexical-binding t)
+ (text-quoting-style 'grave)
(byte-compile-log-buffer (generate-new-buffer " *Compile-Log*")))
;; Check that we get a warning without suppression.
(with-current-buffer byte-compile-log-buffer
@@ -1299,8 +1457,8 @@ literals (Bug#20852)."
'(defun zot ()
(mapcar #'list '(1 2 3))
nil)
- '((mapcar mapcar))
- "Warning: .mapcar. called for effect")
+ '((ignored-return-value mapcar))
+ "Warning: value from call to `mapcar' is unused; use `mapc' or `dolist' instead")
(test-suppression
'(defun zot ()
@@ -1314,7 +1472,92 @@ literals (Bug#20852)."
(set-buffer (get-buffer-create "foo"))
nil))
'((suspicious set-buffer))
- "Warning: Use .with-current-buffer. rather than"))
+ "Warning: Use .with-current-buffer. rather than")
+
+ (test-suppression
+ '(defun zot (x)
+ (condition-case nil (list x)))
+ '((suspicious condition-case))
+ "Warning: `condition-case' without handlers")
+
+ (test-suppression
+ '(defun zot (x)
+ (unwind-protect (print x)))
+ '((suspicious unwind-protect))
+ "Warning: `unwind-protect' without unwind forms")
+
+ (test-suppression
+ '(defun zot ()
+ (let ((_ 1))
+ ))
+ '((empty-body let))
+ "Warning: `let' with empty body")
+
+ (test-suppression
+ '(defun zot ()
+ (let* ((_ 1))
+ ))
+ '((empty-body let*))
+ "Warning: `let\\*' with empty body")
+
+ (test-suppression
+ '(defun zot (x)
+ (when x
+ ))
+ '((empty-body when))
+ "Warning: `when' with empty body")
+
+ (test-suppression
+ '(defun zot (x)
+ (unless x
+ ))
+ '((empty-body unless))
+ "Warning: `unless' with empty body")
+
+ (test-suppression
+ '(defun zot (x)
+ (ignore-error arith-error
+ ))
+ '((empty-body ignore-error))
+ "Warning: `ignore-error' with empty body")
+
+ (test-suppression
+ '(defun zot (x)
+ (with-suppressed-warnings ((suspicious eq))
+ ))
+ '((empty-body with-suppressed-warnings))
+ "Warning: `with-suppressed-warnings' with empty body")
+
+ (test-suppression
+ '(defun zot ()
+ (setcar '(1 2) 3))
+ '((mutate-constant setcar))
+ "Warning: `setcar' on constant list (arg 1)")
+
+ (test-suppression
+ '(defun zot ()
+ (aset [1 2] 1 3))
+ '((mutate-constant aset))
+ "Warning: `aset' on constant vector (arg 1)")
+
+ (test-suppression
+ '(defun zot ()
+ (aset "abc" 1 ?d))
+ '((mutate-constant aset))
+ "Warning: `aset' on constant string (arg 1)")
+
+ (test-suppression
+ '(defun zot (x y)
+ (nconc x y '(1 2) '(3 4)))
+ '((mutate-constant nconc))
+ "Warning: `nconc' on constant list (arg 3)")
+
+ (test-suppression
+ '(defun zot ()
+ (put-text-property 0 2 'prop 'val "abc"))
+ '((mutate-constant put-text-property))
+ "Warning: `put-text-property' on constant string (arg 5)")
+ )
(ert-deftest bytecomp-tests--not-writable-directory ()
"Test that byte compilation works if the output directory isn't
@@ -1565,11 +1808,11 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
(TEST-IN-COMMENTS t) (TEST-IN-STRINGS t) (TEST-IN-CODE t) \
(FIXTURE-FN \\='#\\='electric-pair-mode))" fill-column)))
-(defun test-bytecomp-defgroup-choice ()
- (should-not (byte-compile--suspicious-defcustom-choice 'integer))
- (should-not (byte-compile--suspicious-defcustom-choice
+(ert-deftest bytecomp-test-defcustom-type-quoted ()
+ (should-not (byte-compile--defcustom-type-quoted 'integer))
+ (should-not (byte-compile--defcustom-type-quoted
'(choice (const :tag "foo" bar))))
- (should (byte-compile--suspicious-defcustom-choice
+ (should (byte-compile--defcustom-type-quoted
'(choice (const :tag "foo" 'bar)))))
(ert-deftest bytecomp-function-attributes ()
@@ -1662,6 +1905,101 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
(should (eq (byte-compile-file src-file) 'no-byte-compile))
(should-not (file-exists-p dest-file))))
+(ert-deftest bytecomp--copy-tree ()
+ (should (null (bytecomp--copy-tree nil)))
+ (let ((print-circle t))
+ (let* ((x '(1 2 (3 4)))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ "((1 2 (3 4)) (1 2 (3 4)))")))
+ (let* ((x '#1=(a #1#))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ "(#1=(a #1#) #2=(a #2#))")))
+ (let* ((x '#1=(#1# a))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ "(#1=(#1# a) #2=(#2# a))")))
+ (let* ((x '((a . #1=(b)) #1#))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ "(((a . #1=(b)) #1#) ((a . #2=(b)) #2#))")))
+ (let* ((x '#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d)))
+ (y (bytecomp--copy-tree x)))
+ (should (equal (prin1-to-string (list x y))
+ (concat
+ "("
+ "#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))"
+ " "
+ "#4=(a #5=(#4# b . #6=(#5# c . #4#)) (#6# d))"
+ ")"))))))
+
+(require 'backtrace)
+
+(defun bytecomp-tests--error-frame (fun args)
+ "Call FUN with ARGS. Return result or (ERROR . BACKTRACE-FRAME)."
+ (let* ((debugger
+ (lambda (&rest args)
+ ;; Make sure Emacs doesn't think our debugger is buggy.
+ (cl-incf num-nonmacro-input-events)
+ (throw 'bytecomp-tests--backtrace
+ (cons args (cadr (backtrace-get-frames debugger))))))
+ (debug-on-error t)
+ (backtrace-on-error-noninteractive nil)
+ (debug-on-quit t)
+ (debug-ignored-errors nil))
+ (catch 'bytecomp-tests--backtrace
+ (apply fun args))))
+
+(defconst bytecomp-tests--byte-op-error-cases
+ '(((car a) (wrong-type-argument listp a))
+ ((cdr 3) (wrong-type-argument listp 3))
+ ((setcar 4 b) (wrong-type-argument consp 4))
+ ((setcdr c 5) (wrong-type-argument consp c))
+ ((nth 2 "abcd") (wrong-type-argument listp "abcd"))
+ ((elt (x y . z) 2) (wrong-type-argument listp z))
+ ((aref [2 3 5] p) (wrong-type-argument fixnump p))
+ ((aref #s(a b c) p) (wrong-type-argument fixnump p))
+ ((aref "abc" p) (wrong-type-argument fixnump p))
+ ((aref [2 3 5] 3) (args-out-of-range [2 3 5] 3))
+ ((aref #s(a b c) 3) (args-out-of-range #s(a b c) 3))
+ ((aset [2 3 5] q 1) (wrong-type-argument fixnump q))
+ ((aset #s(a b c) q 1) (wrong-type-argument fixnump q))
+ ((aset [2 3 5] -1 1) (args-out-of-range [2 3 5] -1))
+ ((aset #s(a b c) -1 1) (args-out-of-range #s(a b c) -1))
+ ;; Many more to add
+ ))
+
+(ert-deftest bytecomp--byte-op-error-backtrace ()
+ "Check that signalling byte ops show up in the backtrace."
+ (dolist (case bytecomp-tests--byte-op-error-cases)
+ (ert-info ((prin1-to-string case) :prefix "case: ")
+ (let* ((call (nth 0 case))
+ (expected-error (nth 1 case))
+ (fun-sym (car call))
+ (actuals (cdr call)))
+ ;; Test both calling the function directly, and calling
+ ;; a byte-compiled η-expansion (lambda (ARGS...) (FUN ARGS...))
+ ;; which should turn the function call into a byte-op.
+ (dolist (mode '(funcall byte-op))
+ (ert-info ((symbol-name mode) :prefix "mode: ")
+ (let* ((fun (pcase-exhaustive mode
+ ('funcall fun-sym)
+ ('byte-op
+ (let* ((nargs (length (cdr call)))
+ (formals (mapcar (lambda (i)
+ (intern (format "x%d" i)))
+ (number-sequence 1 nargs))))
+ (byte-compile
+ `(lambda ,formals (,fun-sym ,@formals)))))))
+ (error-frame (bytecomp-tests--error-frame fun actuals)))
+ (should (consp error-frame))
+ (should (equal (car error-frame) (list 'error expected-error)))
+ (let ((frame (cdr error-frame)))
+ (should (equal (type-of frame) 'backtrace-frame))
+ (should (equal (cons (backtrace-frame-fun frame)
+ (backtrace-frame-args frame))
+ call))))))))))
;; Local Variables:
;; no-byte-compile: t
diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el
index 83013cf46a9..6facd3452ea 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -364,5 +364,30 @@
(call-interactively f))
'((t 51696) (nil 51695) (t 51697)))))))
+(ert-deftest cconv-safe-for-space ()
+ (let* ((magic-string "This-is-a-magic-string")
+ (safe-p (lambda (x) (not (string-match magic-string (format "%S" x))))))
+ (should (funcall safe-p (lambda (x) (+ x 1))))
+ (should (funcall safe-p (eval '(lambda (x) (+ x 1))
+ `((y . ,magic-string)))))
+ (should (funcall safe-p (eval '(lambda (x) :closure-dont-trim-context)
+ `((y . ,magic-string)))))
+ (should-not (funcall safe-p
+ (eval '(lambda (x) :closure-dont-trim-context (+ x 1))
+ `((y . ,magic-string)))))))
+
+(ert-deftest cconv-tests-interactive-form-modify-bug60974 ()
+ (let* ((f '(function (lambda (&optional arg)
+ (interactive
+ (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ 'toggle)))
+ (ignore arg))))
+ (if (cadr (nth 2 (cadr f))))
+ (if2))
+ (cconv-closure-convert f)
+ (setq if2 (cadr (nth 2 (cadr f))))
+ (should (eq if if2))))
+
(provide 'cconv-tests)
;;; cconv-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el
index d5886626bf1..b14731c4d0a 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -404,7 +404,7 @@
(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 (equal (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)
@@ -431,7 +431,8 @@
(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)))))
+ (with-suppressed-warnings ((suspicious memql))
+ (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
@@ -529,7 +530,7 @@
(ert-deftest old-struct ()
(cl-defstruct foo x)
- (let ((x [cl-struct-foo])
+ (let ((x (vector 'cl-struct-foo))
(saved cl-old-struct-compat-mode))
(cl-old-struct-compat-mode -1)
(should (eq (type-of x) 'vector))
@@ -539,7 +540,7 @@
(let ((cl-struct-foo (cl--struct-get-class 'foo)))
(setf (symbol-function 'cl-struct-foo) :quick-object-witness-check)
(should (eq (type-of x) 'foo))
- (should (eq (type-of [foo]) 'vector)))
+ (should (eq (type-of (vector 'foo)) 'vector)))
(cl-old-struct-compat-mode (if saved 1 -1))))
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index a9ec0b76ae8..983cbfc8bc7 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -535,7 +535,7 @@ collection clause."
(eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))) t))
;; Make sure `gv-synthetic-place' isn't macro-expanded before `setf' gets to
;; see its `gv-expander'.
- (should (equal (let ((l '(0)))
+ (should (equal (let ((l (list 0)))
(let ((cl (car l)))
(cl-symbol-macrolet
((p (gv-synthetic-place cl (lambda (v) `(setcar l ,v)))))
@@ -803,10 +803,30 @@ See Bug#57915."
(macroexpand form)
(should (string-empty-p messages))))))))
+(defvar cl--test-a)
+
(ert-deftest cl-&key-arguments ()
(cl-flet ((fn (&key x) x))
(should-error (fn :x))
- (should (eq (fn :x :a) :a))))
-
+ (should (eq (fn :x :a) :a)))
+ ;; In ELisp function arguments are always statically scoped (bug#47552).
+ (let ((cl--test-a 'dyn)
+ ;; FIXME: How do we silence the "Lexical argument shadows" warning?
+ (f
+ (with-suppressed-warnings ((lexical cl--test-a))
+ (cl-function (lambda (&key cl--test-a b)
+ (list cl--test-a (symbol-value 'cl--test-a) b))))))
+ (should (equal (funcall f :cl--test-a 'lex :b 2) '(lex dyn 2)))))
+
+(cl-defstruct cl--test-s
+ cl--test-a b)
+
+(ert-deftest cl-defstruct-dynbound-label-47552 ()
+ "Check that labels can have the same name as dynbound vars."
+ (let ((cl--test-a 'dyn))
+ (let ((x (make-cl--test-s :cl--test-a 4 :b cl--test-a)))
+ (should (cl--test-s-p x))
+ (should (equal (cl--test-s-cl--test-a x) 4))
+ (should (equal (cl--test-s-b x) 'dyn)))))
;;; cl-macs-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el
index 7161035d75a..3073a42e39d 100644
--- a/test/lisp/emacs-lisp/cl-print-tests.el
+++ b/test/lisp/emacs-lisp/cl-print-tests.el
@@ -25,6 +25,7 @@
;;; Code:
(require 'ert)
+(require 'cl-print)
(cl-defstruct (cl-print-tests-struct
(:constructor cl-print-tests-con))
@@ -90,7 +91,7 @@
(ert-deftest cl-print-tests-ellipsis-circular ()
"Ellipsis expansion works with circular objects."
(let ((wide-obj (list 0 1 2 3 4))
- (deep-obj `(0 (1 (2 (3 (4))))))
+ (deep-obj (list 0 (list 1 (list 2 (list 3 (list 4))))))
(print-length 4)
(print-level 3))
(setf (nth 4 wide-obj) wide-obj)
@@ -113,7 +114,7 @@
(should pos)
(setq value (get-text-property pos 'cl-print-ellipsis result))
(should (equal expected result))
- (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis
+ (should (equal expanded (with-output-to-string (cl-print--expand-ellipsis
value nil))))))
(defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded)
@@ -122,7 +123,7 @@
(value (get-text-property pos 'cl-print-ellipsis result)))
(should (string-match expected result))
(should (string-match expanded (with-output-to-string
- (cl-print-expand-ellipsis value nil))))))
+ (cl-print--expand-ellipsis value nil))))))
(ert-deftest cl-print-tests-print-to-string-with-limit ()
(let* ((thing10 (make-list 10 'a))
diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el
index de2fff5ef19..28a7f38c576 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -116,6 +116,7 @@ back to the top level.")
(with-current-buffer (find-file edebug-tests-temp-file)
(read-only-mode)
(setq lexical-binding t)
+ (syntax-ppss)
(eval-buffer)
,@body
(when edebug-tests-failure-in-post-command
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
index 4feaebed452..4f13881dbd4 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
@@ -40,7 +40,7 @@ This is usually a symbol that starts with `:'."
(car tuple)
nil)))
-(defun hash-equal (hash1 hash2)
+(defun eieio-test--hash-equal (hash1 hash2)
"Compare two hash tables to see whether they are equal."
(and (= (hash-table-count hash1)
(hash-table-count hash2))
@@ -78,7 +78,7 @@ This is usually a symbol that starts with `:'."
(if initarg-p
(unless
(cond ((and (hash-table-p origvalue) (hash-table-p fromdiskvalue))
- (hash-equal origvalue fromdiskvalue))
+ (eieio-test--hash-equal origvalue fromdiskvalue))
(t (equal origvalue fromdiskvalue)))
(error "Slot %S Original Val %S != Persistent Val %S"
oneslot origvalue fromdiskvalue))
@@ -87,7 +87,7 @@ This is usually a symbol that starts with `:'."
(diskval fromdiskvalue))
(unless
(cond ((and (hash-table-p origval) (hash-table-p diskval))
- (hash-equal origval diskval))
+ (eieio-test--hash-equal origval diskval))
(t (equal origval diskval)))
(error "Slot %S Persistent Val %S != Default Value %S"
oneslot diskval origvalue))))))))
@@ -329,8 +329,8 @@ persistent class.")
"container-" emacs-version ".eieio")))
(john (make-instance 'person :name "John"))
(alexie (make-instance 'person :name "Alexie"))
- (alst '(("first" (one two three))
- ("second" (four five six)))))
+ (alst (list (list "first" (list 'one 'two 'three))
+ (list "second" (list 'four 'five 'six)))))
(setf (slot-value thing 'alist) alst)
(puthash "alst" alst (slot-value thing 'htab))
(aset (slot-value thing 'vec) 0 alst)
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el
index 3e499fc6f59..7713a0f6e38 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -577,13 +577,12 @@ This macro is used to test if macroexpansion in `should' works."
(lambda (format-string &rest args)
(push (apply #'format format-string args) messages))))
(save-window-excursion
- (unwind-protect
- (let ((case-fold-search nil)
- (ert-batch-backtrace-right-margin nil)
- (ert-batch-print-level 10)
- (ert-batch-print-length 11))
- (ert-run-tests-batch
- `(member ,failing-test-1 ,failing-test-2))))))
+ (let ((case-fold-search nil)
+ (ert-batch-backtrace-right-margin nil)
+ (ert-batch-print-level 10)
+ (ert-batch-print-length 11))
+ (ert-run-tests-batch
+ `(member ,failing-test-1 ,failing-test-2)))))
(let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$")
(complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$")
found-long
@@ -609,14 +608,13 @@ This macro is used to test if macroexpansion in `should' works."
(lambda (format-string &rest args)
(push (apply #'format format-string args) messages))))
(save-window-excursion
- (unwind-protect
- (let ((case-fold-search nil)
- (ert-batch-backtrace-right-margin nil)
- (ert-batch-backtrace-line-length nil)
- (ert-batch-print-level 6)
- (ert-batch-print-length 11))
- (ert-run-tests-batch
- `(member ,failing-test-1))))))
+ (let ((case-fold-search nil)
+ (ert-batch-backtrace-right-margin nil)
+ (ert-batch-backtrace-line-length nil)
+ (ert-batch-print-level 6)
+ (ert-batch-print-length 11))
+ (ert-run-tests-batch
+ `(member ,failing-test-1)))))
(let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))")
found-frame)
(cl-loop for msg in (reverse messages)
diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el
index 3e906497020..825e6b6ab80 100644
--- a/test/lisp/emacs-lisp/lisp-mode-tests.el
+++ b/test/lisp/emacs-lisp/lisp-mode-tests.el
@@ -355,5 +355,28 @@ Expected initialization file: `%s'\"
;; (should (equal (lisp-current-defun-name) "defblarg")))
)
+(ert-deftest test-font-lock-keywords ()
+ "Keywords should be fontified in `font-lock-keyword-face`."
+ (with-temp-buffer
+ (emacs-lisp-mode)
+ (mapc (lambda (el-keyword)
+ (erase-buffer)
+ (insert (format "(%s some-symbol () \"hello\"" el-keyword))
+ (font-lock-ensure)
+ ;; Verify face property throughout the keyword
+ (let* ((begin (1+ (point-min)))
+ (end (1- (+ begin (length el-keyword)))))
+ (mapc (lambda (pos)
+ (should (equal (get-text-property pos 'face)
+ 'font-lock-keyword-face)))
+ (number-sequence begin end))))
+ '("defsubst" "cl-defsubst" "define-inline"
+ "define-advice" "defadvice" "defalias"
+ "define-derived-mode" "define-minor-mode"
+ "define-generic-mode" "define-global-minor-mode"
+ "define-globalized-minor-mode" "define-skeleton"
+ "define-widget" "ert-deftest" "defconst" "defcustom"
+ "defvaralias" "defvar-local" "defface" "define-error"))))
+
(provide 'lisp-mode-tests)
;;; lisp-mode-tests.el ends here
diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el
index 7bb38fe58f7..d0efbfd28c1 100644
--- a/test/lisp/emacs-lisp/macroexp-tests.el
+++ b/test/lisp/emacs-lisp/macroexp-tests.el
@@ -124,4 +124,20 @@
(dyn dyn dyn dyn)
(dyn dyn dyn lex))))))
+(defmacro macroexp--test-macro1 ()
+ (declare (obsolete "new-replacement" nil))
+ 1)
+
+(defmacro macroexp--test-macro2 ()
+ '(macroexp--test-macro1))
+
+(ert-deftest macroexp--test-obsolete-macro ()
+ (should
+ (let ((res
+ (cl-letf (((symbol-function 'message) #'user-error))
+ (condition-case err
+ (macroexpand-all '(macroexp--test-macro2))
+ (user-error (error-message-string err))))))
+ (should (and (stringp res) (string-match "new-replacement" res))))))
+
;;; macroexp-tests.el ends here
diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el
index 86c0e9e0503..2204743f794 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -577,6 +577,13 @@ See bug#58531#25 and bug#58563."
(should (= b 2))
(should-not c)))
+(ert-deftest test-map-let-default ()
+ (map-let (('foo a 3)
+ ('baz b 4))
+ '((foo . 1))
+ (should (equal a 1))
+ (should (equal b 4))))
+
(ert-deftest test-map-merge ()
"Test `map-merge'."
(should (equal (sort (map-merge 'list '(a 1) '((b . 2) (c . 3))
@@ -617,6 +624,58 @@ See bug#58531#25 and bug#58563."
(list one two))
'(1 2)))))
+(ert-deftest test-map-plist-pcase-default ()
+ (let ((plist '(:two 2)))
+ (should (equal (pcase-let (((map (:two two 33)
+ (:three three 44))
+ plist))
+ (list two three))
+ '(2 44)))))
+
+(ert-deftest test-map-pcase-matches ()
+ (let ((plist '(:two 2)))
+ (should (equal (pcase plist
+ ((map (:two two 33)
+ (:three three))
+ (list two three))
+ (_ 'fail))
+ '(2 nil)))
+
+ (should (equal (pcase plist
+ ((map (:two two 33)
+ (:three three 44))
+ (list two three))
+ (_ 'fail))
+ '(2 44)))
+
+ (should (equal (pcase plist
+ ((map (:two two 33)
+ (:three `(,a . ,b) '(11 . 22)))
+ (list two a b))
+ (_ 'fail))
+ '(2 11 22)))
+
+ (should (equal 'fail
+ (pcase plist
+ ((map (:two two 33)
+ (:three `(,a . ,b) 44))
+ (list two a b))
+ (_ 'fail))))
+
+ (should (equal 'fail
+ (pcase plist
+ ((map (:two two 33)
+ (:three `(,a . ,b) nil))
+ (list two a b))
+ (_ 'fail))))
+
+ (should (equal 'fail
+ (pcase plist
+ ((map (:two two 33)
+ (:three `(,a . ,b)))
+ (list two a b))
+ (_ 'fail))))))
+
(ert-deftest test-map-setf-alist-insert-key ()
(let ((alist))
(should (equal (setf (map-elt alist 'key) 'value)
diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el
index c55db6491cd..639a8ab5219 100644
--- a/test/lisp/emacs-lisp/multisession-tests.el
+++ b/test/lisp/emacs-lisp/multisession-tests.el
@@ -94,7 +94,7 @@
(dotimes (i 100)
(cl-incf (multisession-value multisession--bar))))))))
(while (process-live-p proc)
- (ignore-error 'sqlite-locked-error
+ (ignore-error sqlite-locked-error
(message "multisession--bar %s" (multisession-value multisession--bar))
;;(cl-incf (multisession-value multisession--bar))
)
diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el
index 748d42f2120..f6bd5733ba3 100644
--- a/test/lisp/emacs-lisp/nadvice-tests.el
+++ b/test/lisp/emacs-lisp/nadvice-tests.el
@@ -29,6 +29,7 @@
(advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2)))
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
(defun sm-test1 (x) (+ x 4))
+ (declare-function sm-test1 nil)
(should (equal (sm-test1 6) 20))
(advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2)))
(should (equal (sm-test1 6) 10))
@@ -62,6 +63,7 @@
(ert-deftest advice-tests-advice ()
"Test advice code."
(defun sm-test2 (x) (+ x 4))
+ (declare-function sm-test2 nil)
(should (equal (sm-test2 6) 10))
(defadvice sm-test2 (around sm-test activate)
ad-do-it (setq ad-return-value (* ad-return-value 5)))
@@ -94,6 +96,7 @@
(ert-deftest advice-tests-combination ()
"Combining old style and new style advices."
(defun sm-test5 (x) (+ x 4))
+ (declare-function sm-test5 nil)
(should (equal (sm-test5 6) 10))
(advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
(should (equal (sm-test5 6) 50))
@@ -112,22 +115,23 @@
(ert-deftest advice-test-called-interactively-p ()
"Check interaction between advice and called-interactively-p."
(defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4))
+ (declare-function sm-test7 nil)
(advice-add 'sm-test7 :around
(lambda (f &rest args)
- (list (cons 1 (called-interactively-p)) (apply f args))))
+ (list (cons 1 (called-interactively-p 'any)) (apply f args))))
(should (equal (sm-test7) '((1 . nil) 11)))
(should (equal (call-interactively 'sm-test7) '((1 . t) 11)))
(let ((smi 7))
(advice-add 'sm-test7 :before
- (lambda (&rest args)
- (setq smi (called-interactively-p))))
+ (lambda (&rest _args)
+ (setq smi (called-interactively-p 'any))))
(should (equal (list (sm-test7) smi)
'(((1 . nil) 11) nil)))
(should (equal (list (call-interactively 'sm-test7) smi)
'(((1 . t) 11) t))))
(advice-add 'sm-test7 :around
(lambda (f &rest args)
- (cons (cons 2 (called-interactively-p)) (apply f args))))
+ (cons (cons 2 (called-interactively-p 'any)) (apply f args))))
(should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11))))
(ert-deftest advice-test-called-interactively-p-around ()
@@ -136,24 +140,28 @@
This tests the currently broken case of the innermost advice to a
function being an around advice."
:expected-result :failed
- (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p)))
+ (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p 'any)))
+ (declare-function sm-test7.2 nil)
(advice-add 'sm-test7.2 :around
(lambda (f &rest args)
- (list (cons 1 (called-interactively-p)) (apply f args))))
+ (list (cons 1 (called-interactively-p 'any)) (apply f args))))
(should (equal (sm-test7.2) '((1 . nil) (1 . nil))))
(should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t)))))
(ert-deftest advice-test-called-interactively-p-filter-args ()
"Check interaction between filter-args advice and called-interactively-p."
:expected-result :failed
- (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p)))
+ (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p 'any)))
+ (declare-function sm-test7.3 nil)
(advice-add 'sm-test7.3 :filter-args #'list)
(should (equal (sm-test7.3) '(1 . nil)))
(should (equal (call-interactively 'sm-test7.3) '(1 . t))))
(ert-deftest advice-test-call-interactively ()
"Check interaction between advice on call-interactively and called-interactively-p."
- (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p))))
+ (let ((sm-test7.4 (lambda ()
+ (interactive)
+ (cons 1 (called-interactively-p 'any))))
(old (symbol-function 'call-interactively)))
(unwind-protect
(progn
@@ -213,8 +221,16 @@ function being an around advice."
(should (equal (cl-prin1-to-string (car x))
"#f(advice first :before #f(advice car :after cdr))"))))
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+(ert-deftest advice-test-bug61179 ()
+ (let* ((magic 42)
+ (ad (lambda (&rest _)
+ (interactive (lambda (is)
+ (cons magic (advice-eval-interactive-spec is))))
+ nil))
+ (sym (make-symbol "adtest")))
+ (defalias sym (lambda (&rest args) (interactive (list 'main)) args))
+ (should (equal (call-interactively sym) '(main)))
+ (advice-add sym :before ad)
+ (should (equal (call-interactively sym) '(42 main)))))
;;; nadvice-tests.el ends here
diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el
index 0016fb586b7..113b4ec12a8 100644
--- a/test/lisp/emacs-lisp/package-tests.el
+++ b/test/lisp/emacs-lisp/package-tests.el
@@ -219,9 +219,14 @@ Must called from within a `tar-mode' buffer."
(ert-deftest package-test-desc-from-buffer ()
"Parse an elisp buffer to get a `package-desc' object."
- (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el")
- (should (package-test--compatible-p
- (package-buffer-info) simple-single-desc 'kind)))
+ (with-package-test (:basedir (ert-resource-directory)
+ :file "simple-single-1.3.el")
+ (let ((pi (package-buffer-info)))
+ (should (package-test--compatible-p pi simple-single-desc 'kind))
+ ;; The terminating line is not mandatory any more.
+ (re-search-forward "^;;; .* ends here")
+ (delete-region (match-beginning 0) (point-max))
+ (should (equal (package-buffer-info) pi))))
(with-package-test (:basedir (ert-resource-directory) :file "simple-depend-1.0.el")
(should (package-test--compatible-p
(package-buffer-info) simple-depend-desc 'kind)))
diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el
index 72c7cb880d2..1b248e19a31 100644
--- a/test/lisp/emacs-lisp/pp-tests.el
+++ b/test/lisp/emacs-lisp/pp-tests.el
@@ -23,8 +23,8 @@
(require 'ert-x)
(ert-deftest pp-print-quote ()
- (should (string= (pp-to-string 'quote) "quote"))
- (should (string= (pp-to-string ''quote) "'quote"))
+ (should (string= (pp-to-string 'quote) "quote\n"))
+ (should (string= (pp-to-string ''quote) "'quote\n"))
(should (string= (pp-to-string '('a 'b)) "('a 'b)\n"))
(should (string= (pp-to-string '(''quote 'quote)) "(''quote 'quote)\n"))
(should (string= (pp-to-string '(quote)) "(quote)\n"))
diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el
index 9c8628a8f26..ae83f28d9c4 100644
--- a/test/lisp/emacs-lisp/rx-tests.el
+++ b/test/lisp/emacs-lisp/rx-tests.el
@@ -98,7 +98,17 @@
"[\177Å\211\326-\377]"))
;; Split range; \177-\377ÿ should not be optimized to \177-\377.
(should (equal (rx (any "\177-\377" ?ÿ))
- "[\177ÿ\200-\377]")))
+ "[\177ÿ\200-\377]"))
+ ;; Range between normal chars and raw bytes: must be split to be parsed
+ ;; correctly by the Emacs regexp engine.
+ (should (equal
+ (rx (any (0 . #x3fffff)) (any (?G . #x3fff9a)) (any (?Ü . #x3ffff2)))
+ "[\0-\x3fff7f\x80-\xff][G-\x3fff7f\x80-\x9a][Ü-\x3fff7f\x80-\xf2]"))
+ ;; As above but with ranges in string form. For historical reasons,
+ ;; we special-case ASCII-to-raw ranges to exclude non-ASCII unicode.
+ (should (equal
+ (rx (any "\x00-\xff") (any "G-\x9a") (any "Ü-\xf2"))
+ "[\0-\x7f\x80-\xff][G-\x7f\x80-\x9a][Ü-\x3fff7f\x80-\xf2]")))
(ert-deftest rx-any ()
(should (equal (rx (any ?A (?C . ?D) "F-H" "J-L" "M" "N-P" "Q" "RS"))
@@ -138,7 +148,7 @@
(should (equal (rx (any "-]^" ascii) (not (any "-]^" ascii)))
"[]^[:ascii:]-][^]^[:ascii:]-]"))
(should (equal (rx (any "^" lower upper) (not (any "^" lower upper)))
- "[[:lower:]^[:upper:]][^^[:lower:][:upper:]]"))
+ "[[:lower:][:upper:]^][^^[:lower:][:upper:]]"))
(should (equal (rx (any "-" lower upper) (not (any "-" lower upper)))
"[[:lower:][:upper:]-][^[:lower:][:upper:]-]"))
(should (equal (rx (any "]" lower upper) (not (any "]" lower upper)))
@@ -274,7 +284,7 @@
"^\\`\\'\\`\\'\\`\\'\\`\\'$"))
(should (equal (rx point word-start word-end bow eow symbol-start symbol-end
word-boundary not-word-boundary not-wordchar)
- "\\=\\<\\>\\<\\>\\_<\\_>\\b\\B\\W"))
+ "\\=\\<\\>\\<\\>\\_<\\_>\\b\\B[^[:word:]]"))
(should (equal (rx digit numeric num control cntrl)
"[[:digit:]][[:digit:]][[:digit:]][[:cntrl:]][[:cntrl:]]"))
(should (equal (rx hex-digit hex xdigit blank)
@@ -296,7 +306,7 @@
(should (equal (rx (syntax whitespace) (syntax punctuation)
(syntax word) (syntax symbol)
(syntax open-parenthesis) (syntax close-parenthesis))
- "\\s-\\s.\\sw\\s_\\s(\\s)"))
+ "\\s-\\s.\\w\\s_\\s(\\s)"))
(should (equal (rx (syntax string-quote) (syntax paired-delimiter)
(syntax escape) (syntax character-quote)
(syntax comment-start) (syntax comment-end)
@@ -344,8 +354,9 @@
"\\B"))
(should (equal (rx (not ascii) (not lower-case) (not wordchar))
"[^[:ascii:]][^[:lower:]][^[:word:]]"))
- (should (equal (rx (not (syntax punctuation)) (not (syntax escape)))
- "\\S.\\S\\"))
+ (should (equal (rx (not (syntax punctuation)) (not (syntax escape))
+ (not (syntax word)))
+ "\\S.\\S\\\\W"))
(should (equal (rx (not (category tone-mark)) (not (category lao)))
"\\C4\\Co"))
(should (equal (rx (not (not ascii)) (not (not (not (any "a-z")))))
@@ -600,6 +611,57 @@
(rx-submatch-n '(group-n 3 (+ nonl) eol)))
"\\(?3:.+$\\)")))
+;;; unit tests for internal functions
+
+(ert-deftest rx--complement-intervals ()
+ (should (equal (rx--complement-intervals '())
+ '((0 . #x3fffff))))
+ (should (equal (rx--complement-intervals '((10 . 20) (30 . 40)))
+ '((0 . 9) (21 . 29) (41 . #x3fffff))))
+ (should (equal (rx--complement-intervals '((0 . #x3fffff)))
+ '()))
+ (should (equal (rx--complement-intervals
+ '((0 . 10) (20 . 20) (30 . #x3fffff)))
+ '((11 . 19) (21 . 29)))))
+
+(ert-deftest rx--union-intervals ()
+ (should (equal (rx--union-intervals '() '()) '()))
+ (should (equal (rx--union-intervals '() '((10 . 20) (30 . 40)))
+ '((10 . 20) (30 . 40))))
+ (should (equal (rx--union-intervals '((10 . 20) (30 . 40)) '())
+ '((10 . 20) (30 . 40))))
+ (should (equal (rx--union-intervals '((5 . 15) (18 . 24) (32 . 40))
+ '((10 . 20) (30 . 40) (50 . 60)))
+ '((5 . 24) (30 . 40) (50 . 60))))
+ (should (equal (rx--union-intervals '((10 . 20) (30 . 40) (50 . 60))
+ '((0 . 9) (21 . 29) (41 . 50)))
+ '((0 . 60))))
+ (should (equal (rx--union-intervals '((10 . 20) (30 . 40))
+ '((12 . 18) (28 . 42)))
+ '((10 . 20) (28 . 42))))
+ (should (equal (rx--union-intervals '((10 . 20) (30 . 40))
+ '((0 . #x3fffff)))
+ '((0 . #x3fffff)))))
+
+(ert-deftest rx--intersect-intervals ()
+ (should (equal (rx--intersect-intervals '() '()) '()))
+ (should (equal (rx--intersect-intervals '() '((10 . 20) (30 . 40)))
+ '()))
+ (should (equal (rx--intersect-intervals '((10 . 20) (30 . 40)) '())
+ '()))
+ (should (equal (rx--intersect-intervals '((5 . 15) (18 . 24) (32 . 40))
+ '((10 . 20) (30 . 40) (50 . 60)))
+ '((10 . 15) (18 . 20) (32 . 40))))
+ (should (equal (rx--intersect-intervals '((10 . 20) (30 . 40) (50 . 60))
+ '((0 . 9) (21 . 29) (41 . 50)))
+ '((50 . 50))))
+ (should (equal (rx--intersect-intervals '((10 . 20) (30 . 40))
+ '((12 . 18) (28 . 42)))
+ '((12 . 18) (30 . 40))))
+ (should (equal (rx--intersect-intervals '((10 . 20) (30 . 40))
+ '((0 . #x3fffff)))
+ '((10 . 20) (30 . 40)))))
+
(provide 'rx-tests)
;;; rx-tests.el ends here
diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el
index 516d095767f..596b47d2543 100644
--- a/test/lisp/emacs-lisp/shortdoc-tests.el
+++ b/test/lisp/emacs-lisp/shortdoc-tests.el
@@ -65,6 +65,49 @@
(when buf
(kill-buffer buf))))))
+(defun shortdoc-tests--to-ascii (x)
+ "Translate Unicode arrows to ASCII for making the test work everywhere."
+ (cond ((consp x)
+ (cons (shortdoc-tests--to-ascii (car x))
+ (shortdoc-tests--to-ascii (cdr x))))
+ ((stringp x)
+ (thread-last x
+ (string-replace "⇒" "=>")
+ (string-replace "→" "->")))
+ (t x)))
+
+(ert-deftest shortdoc-function-examples-test ()
+ "Test the extraction of usage examples of some Elisp functions."
+ (should (equal '((list . "(delete 2 (list 1 2 3 4))\n => (1 3 4)\n (delete \"a\" (list \"a\" \"b\" \"c\" \"d\"))\n => (\"b\" \"c\" \"d\")"))
+ (shortdoc-tests--to-ascii
+ (shortdoc-function-examples 'delete))))
+ (should (equal '((alist . "(assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)")
+ (list . "(assq 'b '((a . 1) (b . 2)))\n => (b . 2)"))
+ (shortdoc-tests--to-ascii
+ (shortdoc-function-examples 'assq))))
+ (should (equal '((regexp . "(string-match-p \"^[fo]+\" \"foobar\")\n => 0"))
+ (shortdoc-tests--to-ascii
+ (shortdoc-function-examples 'string-match-p)))))
+
+(ert-deftest shortdoc-help-fns-examples-function-test ()
+ "Test that `shortdoc-help-fns-examples-function' correctly prints ELisp function examples."
+ (with-temp-buffer
+ (shortdoc-help-fns-examples-function 'string-fill)
+ (should (equal "\n Examples:\n\n (string-fill \"Three short words\" 12)\n => \"Three short\\nwords\"\n (string-fill \"Long-word\" 3)\n => \"Long-word\"\n\n"
+ (shortdoc-tests--to-ascii
+ (buffer-substring-no-properties (point-min) (point-max)))))
+ (erase-buffer)
+ (shortdoc-help-fns-examples-function 'assq)
+ (should (equal "\n Examples:\n\n (assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)\n\n (assq 'b '((a . 1) (b . 2)))\n => (b . 2)\n\n"
+ (shortdoc-tests--to-ascii
+ (buffer-substring-no-properties (point-min) (point-max)))))
+ (erase-buffer)
+ (shortdoc-help-fns-examples-function 'string-trim)
+ (should (equal "\n Example:\n\n (string-trim \" foo \")\n => \"foo\"\n\n"
+ (shortdoc-tests--to-ascii
+ (buffer-substring-no-properties (point-min)
+ (point-max)))))))
+
(provide 'shortdoc-tests)
;;; shortdoc-tests.el ends here
diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el
index e4c270a114f..63d8fcd080c 100644
--- a/test/lisp/emacs-lisp/subr-x-tests.el
+++ b/test/lisp/emacs-lisp/subr-x-tests.el
@@ -709,14 +709,15 @@
[(raise 0.5) (height 2.0)]))
(should (equal (get-text-property 9 'display) '(raise 0.5))))
(with-temp-buffer
- (should (equal (let ((str "some useless string"))
- (add-display-text-property 4 8 'height 2.0 str)
- (add-display-text-property 2 12 'raise 0.5 str)
- str)
- #("some useless string"
- 2 4 (display (raise 0.5))
- 4 8 (display ((raise 0.5) (height 2.0)))
- 8 12 (display (raise 0.5)))))))
+ (should (equal-including-properties
+ (let ((str (copy-sequence "some useless string")))
+ (add-display-text-property 4 8 'height 2.0 str)
+ (add-display-text-property 2 12 'raise 0.5 str)
+ str)
+ #("some useless string"
+ 2 4 (display (raise 0.5))
+ 4 8 (display ((raise 0.5) (height 2.0)))
+ 8 12 (display (raise 0.5)))))))
(ert-deftest subr-x-named-let ()
(let ((funs ()))
generated by cgit v1.2.3 (git 2.39.1) at 2025-07-22 15:06:26 +0000