From 536cda1f84f3be1959e5a475e51dbecaa2253bfd Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 22 Sep 2014 11:04:12 -0400 Subject: [PATCH] * lisp/emacs-lisp/pcase.el (pcase-defmacro): New macro. (pcase--macroexpand): New function. (pcase--expand): Use it. --- etc/NEWS | 1 + lisp/ChangeLog | 4 ++++ lisp/emacs-lisp/pcase.el | 27 ++++++++++++++++++++++++++- 3 files changed, 31 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index cbad7c5b54b..397b8866f6b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -104,6 +104,7 @@ performance improvements when pasting large amounts of text. ** pcase *** New UPatterns `quote' and `app'. +*** New UPatterns can be defined with `pcase-defmacro'. ** Lisp mode *** Strings after `:documentation' are highlighted as docstrings. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 1aad2004d6a..32843569eda 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,9 @@ 2014-09-22 Stefan Monnier + * emacs-lisp/pcase.el (pcase-defmacro): New macro. + (pcase--macroexpand): New function. + (pcase--expand): Use it. + Add support for `quote' and `app'. * emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest): New optimization functions. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index fbe241b6fc8..2d5f19fe5f7 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -284,7 +284,7 @@ of the form (UPAT EXP)." (main (pcase--u (mapcar (lambda (case) - `((match ,val . ,(car case)) + `((match ,val . ,(pcase--macroexpand (car case))) ,(lambda (vars) (unless (memq case used-cases) ;; Keep track of the cases that are used. @@ -303,6 +303,31 @@ of the form (UPAT EXP)." (message "Redundant pcase pattern: %S" (car case)))) (macroexp-let* defs main)))) +(defun pcase--macroexpand (pat) + "Expands all macro-patterns in PAT." + (let ((head (car-safe pat))) + (cond + ((memq head '(nil pred guard quote)) pat) + ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat)))) + ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) + ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) + (t + (let* ((expander (get head 'pcase-macroexpander)) + (npat (if expander (apply expander (cdr pat))))) + (if (null npat) + (error (if expander + "Unexpandable %s pattern: %S" + "Unknown %s pattern: %S") + head pat) + (pcase--macroexpand npat))))))) + +;;;###autoload +(defmacro pcase-defmacro (name args &rest body) + "Define a pcase UPattern macro." + (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3)) + `(put ',name 'pcase-macroexpander + (lambda ,args ,@body))) + (defun pcase-codegen (code vars) ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy -- 2.39.5