procyberian/emacs
2
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-let*): Use it.  Use pcase--memoize to avoid repeated expansions.
(pcase--expand): Use macroexp-let².
This commit is contained in:
Stefan Monnier 2012-06-10 20:33:33 -04:00
parent cef5bb19dc
commit 82ad98e37d
2 changed files with 96 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

6
lisp/ChangeLog
View file

@ -1,3 +1,9 @@
2012-06-11 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/pcase.el (pcase--let*): New function.
(pcase-let*): Use it. Use pcase--memoize to avoid repeated expansions.
(pcase--expand): Use macroexp-let².
2012-06-10 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/timer.el, emacs-lisp/syntax.el, emacs-lisp/smie.el:

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

@ -61,6 +61,8 @@
;; memoize previous macro expansions to try and avoid recomputing them
;; over and over again.
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
(defconst pcase--dontcare-upats '(t _ dontcare))
@ -107,31 +109,49 @@ like `(,a . ,(pred (< a))) or, with more checks:
(if (and (equal exp (car data)) (equal cases (cadr data)))
;; We have the right expansion.
(cddr data)
;; (when (gethash (car cases) pcase--memoize-1)
;; (message "pcase-memoize failed because of weak key!!"))
;; (when (gethash (car cases) pcase--memoize-2)
;; (message "pcase-memoize failed because of eq test on %S"
;; (car cases)))
(when data
(message "pcase-memoize: equal first branch, yet different"))
(let ((expansion (pcase--expand exp cases)))
(puthash (car cases) (cons exp (cons cases expansion)) pcase--memoize)
(puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
expansion))))
(defun pcase--let* (bindings body)
(cond
((null bindings) (macroexp-progn body))
((pcase--trivial-upat-p (caar bindings))
(macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
(t
(let ((binding (pop bindings)))
(pcase--expand
(cadr binding)
`((,(car binding) ,(pcase--let* bindings body))
;; We can either signal an error here, or just use `dontcare' which
;; generates more efficient code. In practice, if we use `dontcare'
;; we will still often get an error and the few cases where we don't
;; do not matter that much, so it's a better choice.
(dontcare nil)))))))
;;;###autoload
(defmacro pcase-let* (bindings &rest body)
"Like `let*' but where you can use `pcase' patterns for bindings.
BODY should be an expression, and BINDINGS should be a list of bindings
of the form (UPAT EXP)."
(declare (indent 1)
(debug ((&rest &or (sexp &optional form) symbolp) body)))
(cond
((null bindings) (if (> (length body) 1) `(progn ,@body) (car body)))
((pcase--trivial-upat-p (caar bindings))
`(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body)))
(t
`(pcase ,(cadr (car bindings))
(,(caar bindings) (pcase-let* ,(cdr bindings) ,@body))
;; We can either signal an error here, or just use `dontcare' which
;; generates more efficient code. In practice, if we use `dontcare' we
;; will still often get an error and the few cases where we don't do not
;; matter that much, so it's a better choice.
(dontcare nil)))))
(debug ((&rest (sexp &optional form)) body)))
(let ((cached (gethash bindings pcase--memoize)))
;; cached = (BODY . EXPANSION)
(if (equal (car cached) body)
(cdr cached)
(let ((expansion (pcase--let* bindings body)))
(puthash bindings (cons body expansion) pcase--memoize)
expansion))))
;;;###autoload
(defmacro pcase-let (bindings &rest body)
@ -169,9 +189,8 @@ of the form (UPAT EXP)."
(defun pcase--expand (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
;; (emacs-pid) exp (sxhash cases))
(let* ((defs (if (symbolp exp) '()
(let ((sym (make-symbol "x")))
(prog1 `((,sym ,exp)) (setq exp sym)))))
(macroexp-let² macroexp-copyable-p val exp
(let* ((defs ())
(seen '())
(codegen
(lambda (code vars)
@ -218,7 +237,7 @@ of the form (UPAT EXP)."
(main
(pcase--u
(mapcar (lambda (case)
`((match ,exp . ,(car case))
`((match ,val . ,(car case))
,(apply-partially
(if (pcase--small-branch-p (cdr case))
;; Don't bother sharing multiple
@ -226,7 +245,6 @@ of the form (UPAT EXP)."
#'pcase-codegen codegen)
(cdr case))))
cases))))
(if (null defs) main
(macroexp-let* defs main))))
(defun pcase-codegen (code vars)