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/bytecomp-tests.el250
-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/ert-tests.el28
-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/shortdoc-tests.el43
7 files changed, 355 insertions, 40 deletions
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index 7ae10cdea73..222065c2e4e 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -704,6 +704,78 @@ 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))
)
"List of expressions for cross-testing interpreted and compiled code.")
@@ -833,13 +905,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 +950,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 +1241,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 +1361,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 +1448,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 +1463,62 @@ 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")
+ )
(ert-deftest bytecomp-tests--not-writable-directory ()
"Test that byte compilation works if the output directory isn't
@@ -1662,6 +1866,34 @@ 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))"
+ ")"))))))
;; 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/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/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/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
generated by cgit v1.2.3 (git 2.39.1) at 2025-06-02 15:23:15 +0000