procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* lisp/emacs-lisp/pcase.el (pcase--let*): New function.

Browse source 
(pcase--expand, pcase-codegen, pcase--q1): Use it to reduce nesting
a bit more.
(pcase--split-pred): Be more clever about ruling out overlap between
a predicate and some constant pattern.
(pcase--q1): Use `null' instead of (eq foo nil).
This commit is contained in:
Stefan Monnier 2012-05-04 22:05:49 -04:00
parent f95e9344c9
commit 5342bb062f
2 changed files with 46 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
lisp/ChangeLog
View file

@ -1,5 +1,12 @@
2012-05-05 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/pcase.el (pcase--let*): New function.
(pcase--expand, pcase-codegen, pcase--q1): Use it to reduce nesting
a bit more.
(pcase--split-pred): Be more clever about ruling out overlap between
a predicate and some constant pattern.
(pcase--q1): Use `null' instead of (eq foo nil).
* subr.el (setq-local, defvar-local): New macros.
(kbd): Redefine as an alias.
(with-selected-window): Leave unrelated frames alone.

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

@ -148,6 +148,7 @@ of the form (UPAT EXP)."
`(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
(defmacro pcase-dolist (spec &rest body)
(declare (indent 1))
(if (pcase--trivial-upat-p (car spec))
`(dolist ,spec ,@body)
(let ((tmpvar (make-symbol "x")))
@ -217,10 +218,10 @@ of the form (UPAT EXP)."
(cdr case))))
cases))))
(if (null defs) main
`(let ,defs ,main))))
(pcase--let* defs main))))
(defun pcase-codegen (code vars)
`(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
`(let* ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
,@code))
(defun pcase--small-branch-p (code)
@ -255,6 +256,13 @@ of the form (UPAT EXP)."
((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then))
(t `(if ,test ,then ,else))))
;; Again, try and reduce nesting.
(defun pcase--let* (binders body)
(if (eq (car-safe body) 'let*)
`(let* ,(append binders (nth 1 body))
,@(nthcdr 2 body))
`(let* ,binders ,body)))
(defun pcase--upat (qpattern)
(cond
((eq (car-safe qpattern) '\,) (cadr qpattern))
@ -433,26 +441,26 @@ MATCH is the pattern that needs to be matched, of the form:
(defun pcase--split-pred (upat pat)
;; FIXME: For predicates like (pred (> a)), two such predicates may
;; actually refer to different variables `a'.
(cond
((equal upat pat) (cons :pcase--succeed :pcase--fail))
((and (eq 'pred (car upat))
(eq 'pred (car-safe pat))
(or (member (cons (cadr upat) (cadr pat))
pcase-mutually-exclusive-predicates)
(member (cons (cadr pat) (cadr upat))
pcase-mutually-exclusive-predicates)))
(cons :pcase--fail nil))
;; ((and (eq 'pred (car upat))
;; (eq '\` (car-safe pat))
;; (symbolp (cadr upat))
;; (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
;; (get (cadr upat) 'side-effect-free)
;; (progn (message "Trying predicate %S" (cadr upat))
;; (ignore-errors
;; (funcall (cadr upat) (cadr pat)))))
;; (message "Simplify pred %S against %S" upat pat)
;; (cons nil :pcase--fail))
))
(let (test)
(cond
((equal upat pat) (cons :pcase--succeed :pcase--fail))
((and (eq 'pred (car upat))
(eq 'pred (car-safe pat))
(or (member (cons (cadr upat) (cadr pat))
pcase-mutually-exclusive-predicates)
(member (cons (cadr pat) (cadr upat))
pcase-mutually-exclusive-predicates)))
(cons :pcase--fail nil))
((and (eq 'pred (car upat))
(eq '\` (car-safe pat))
(symbolp (cadr upat))
(or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
(get (cadr upat) 'side-effect-free)
(ignore-errors
(setq test (list (funcall (cadr upat) (cadr pat))))))
(if (car test)
(cons nil :pcase--fail)
(cons :pcase--fail nil))))))
(defun pcase--fgrep (vars sexp)
"Check which of the symbols VARS appear in SEXP."
@ -673,16 +681,22 @@ Otherwise, it defers to REST which is a list of branches of the form
;; The byte-compiler could do that for us, but it would have to pay
;; attention to the `consp' test in order to figure out that car/cdr
;; can't signal errors and our byte-compiler is not that clever.
`(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
;; FIXME: Some of those let bindings occur too early (they are used in
;; `then-body', but only within some sub-branch).
(pcase--let*
`(,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
,then-body)
then-body)
(pcase--u else-rest))))
((or (integerp qpat) (symbolp qpat) (stringp qpat))
(let* ((splitrest (pcase--split-rest
sym (apply-partially 'pcase--split-equal qpat) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
(pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat)
(pcase--if (cond
((stringp qpat) `(equal ,sym ,qpat))
((null qpat) `(null ,sym))
(t `(eq ,sym ',qpat)))
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
(t (error "Unknown QPattern %s" qpat))))