Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-16 17:24:23 +00:00
Code Issues Projects Releases Packages Wiki Activity

Neater pcase predicate transform

Browse source 
Suggested by Stefan Monnier.

* lisp/emacs-lisp/pcase.el (pcase--macroexpand): Simplify.
* test/lisp/emacs-lisp/pcase-tests.el (pcase-pred-equiv): New test.
This commit is contained in:
Mattias Engdegård 2026-01-23 22:05:28 +01:00
parent 0fcf100301
commit fd9d685c63
2 changed files with 24 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
lisp/emacs-lisp/pcase.el
View file

@ -525,15 +525,13 @@ how many time this CODEGEN is called."
(if (pcase--self-quoting-p pat) `',pat pat))
((memq head '(guard quote)) pat)
((eq head 'pred)
;; Ad-hoc expansion of some predicates that are the complement of another.
;; Ad-hoc expansion of some predicates that are complements or aliases.
;; Not required for correctness but results in better code.
(let* ((expr (cadr pat))
(compl (assq expr '((atom . consp)
(nlistp . listp)
(identity . null)))))
(cond (compl `(,head (not ,(cdr compl))))
((eq expr 'not) `(,head null)) ; normalise
(t pat))))
(let ((equiv (assq (cadr pat) '((atom . (not consp))
(nlistp . (not listp))
(identity . (not null))
(not . null)))))
(if equiv `(,head ,(cdr equiv)) pat)))
((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
(t

18
test/lisp/emacs-lisp/pcase-tests.el
View file

@ -192,4 +192,22 @@
(should (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x)))
(should-not (pcase--mutually-exclusive-p (nth 1 x) (nth 0 x))))))
(ert-deftest pcase-pred-equiv ()
(cl-flet ((f1 (x) (pcase x ((pred atom) 1) (_ 2))))
(should (equal (f1 'a) 1))
(should (equal (f1 nil) 1))
(should (equal (f1 '(a)) 2)))
(cl-flet ((f2 (x) (pcase x ((pred nlistp) 1) (_ 2))))
(should (equal (f2 'a) 1))
(should (equal (f2 nil) 2))
(should (equal (f2 '(a)) 2)))
(cl-flet ((f3 (x) (pcase x ((pred identity) 1) (_ 2))))
(should (equal (f3 'a) 1))
(should (equal (f3 nil) 2))
(should (equal (f3 '(a)) 1)))
(cl-flet ((f4 (x) (pcase x ((pred not) 1) (_ 2))))
(should (equal (f4 'a) 2))
(should (equal (f4 nil) 1))
(should (equal (f4 '(a)) 2))))
;;; pcase-tests.el ends here.