diff options
Diffstat (limited to 'lisp/emacs-lisp/pcase.el')
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 89 |
1 files changed, 51 insertions, 38 deletions
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 3179672a3ec..d795dbd390c 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -1,4 +1,4 @@ -;;; pcase.el --- ML-style pattern-matching macro for Elisp +;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*- ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. @@ -37,8 +37,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - ;; Macro-expansion of pcase is reasonably fast, so it's not a problem ;; when byte-compiling a file, but when interpreting the code, if the pcase ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we @@ -157,7 +155,9 @@ of the form (UPAT EXP)." ;; to a separate function if that number is too high. ;; ;; We've already used this branch. So it is shared. - (destructuring-bind (code prevvars res) prev + (let* ((code (car prev)) (cdrprev (cdr prev)) + (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) + (res (car cddrprev))) (unless (symbolp res) ;; This is the first repeat, so we have to move ;; the branch to a separate function. @@ -258,15 +258,18 @@ MATCH is the pattern that needs to be matched, of the form: (and MATCH ...) (or MATCH ...)" (when (setq branches (delq nil branches)) - (destructuring-bind (match code &rest vars) (car branches) + (let* ((carbranch (car branches)) + (match (car carbranch)) (cdarbranch (cdr carbranch)) + (code (car cdarbranch)) + (vars (cdr cdarbranch))) (pcase--u1 (list match) code vars (cdr branches))))) (defun pcase--and (match matches) (if matches `(and ,match ,@matches) match)) (defun pcase--split-match (sym splitter match) - (case (car match) - ((match) + (cond + ((eq (car match) 'match) (if (not (eq sym (cadr match))) (cons match match) (let ((pat (cddr match))) @@ -280,7 +283,7 @@ MATCH is the pattern that needs to be matched, of the form: (cdr pat))))) (t (let ((res (funcall splitter (cddr match)))) (cons (or (car res) match) (or (cdr res) match)))))))) - ((or and) + ((memq (car match) '(or and)) (let ((then-alts '()) (else-alts '()) (neutral-elem (if (eq 'or (car match)) @@ -410,32 +413,37 @@ and otherwise defers to REST which is a list of branches of the form (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) code vars (if (null others) rest - (cons (list* + (cons (cons (pcase--and (if (cdr others) (cons 'or (nreverse others)) (car others)) (cdr matches)) - code vars) + (cons code vars)) rest)))) (t (pcase--u1 (cons (pop alts) (cdr matches)) code vars (if (null alts) (progn (error "Please avoid it") rest) - (cons (list* + (cons (cons (pcase--and (if (cdr alts) (cons 'or alts) (car alts)) (cdr matches)) - code vars) + (cons code vars)) rest))))))) ((eq 'match (caar matches)) - (destructuring-bind (op sym &rest upat) (pop matches) + (let* ((popmatches (pop matches)) + (op (car popmatches)) (cdrpopmatches (cdr popmatches)) + (sym (car cdrpopmatches)) + (upat (cdr cdrpopmatches))) (cond ((memq upat '(t _)) (pcase--u1 matches code vars rest)) ((eq upat 'dontcare) :pcase--dontcare) ((functionp upat) (error "Feature removed, use (pred %s)" upat)) ((memq (car-safe upat) '(guard pred)) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest - sym (apply-partially #'pcase--split-pred upat) rest) + (let* ((splitrest + (pcase--split-rest + sym (apply-partially #'pcase--split-pred upat) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) `(,(cadr upat) ,sym) (let* ((exp (cadr upat)) @@ -479,13 +487,15 @@ and otherwise defers to REST which is a list of branches of the form (setq all nil)))) (if all ;; Use memq for (or `a `b `c `d) rather than a big tree. - (let ((elems (mapcar 'cadr (cdr upat)))) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest - sym (apply-partially #'pcase--split-member elems) rest) - (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) - (pcase--u1 matches code vars then-rest) - (pcase--u else-rest)))) + (let* ((elems (mapcar 'cadr (cdr upat))) + (splitrest + (pcase--split-rest + sym (apply-partially #'pcase--split-member elems) rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) + (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) + (pcase--u1 matches code vars then-rest) + (pcase--u else-rest))) (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars (append (mapcar (lambda (upat) `((and (match ,sym . ,upat) ,@matches) @@ -508,15 +518,14 @@ and otherwise defers to REST which is a list of branches of the form ;; `(PAT3 . PAT4)) which the programmer can easily rewrite ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). (pcase--u1 `((match ,sym . ,(cadr upat))) - (lexical-let ((rest rest)) - ;; FIXME: This codegen is not careful to share its - ;; code if used several times: code blow up is likely. - (lambda (vars) - ;; `vars' will likely contain bindings which are - ;; not always available in other paths to - ;; `rest', so there' no point trying to pass - ;; them down. - (pcase--u rest))) + ;; FIXME: This codegen is not careful to share its + ;; code if used several times: code blow up is likely. + (lambda (vars) + ;; `vars' will likely contain bindings which are + ;; not always available in other paths to + ;; `rest', so there' no point trying to pass + ;; them down. + (pcase--u rest)) vars (list `((and . ,matches) ,code . ,vars)))) (t (error "Unknown upattern `%s'" upat))))) @@ -535,10 +544,12 @@ and if not, defers to REST which is a list of branches of the form ((consp qpat) (let ((syma (make-symbol "xcar")) (symd (make-symbol "xcdr"))) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest sym - (apply-partially #'pcase--split-consp syma symd) - rest) + (let* ((splitrest (pcase--split-rest + sym + (apply-partially #'pcase--split-consp syma symd) + rest)) + (then-rest (car splitrest)) + (else-rest (cdr splitrest))) (pcase--if `(consp ,sym) `(let ((,syma (car ,sym)) (,symd (cdr ,sym))) @@ -548,8 +559,10 @@ and if not, defers to REST which is a list of branches of the form code vars then-rest)) (pcase--u else-rest))))) ((or (integerp qpat) (symbolp qpat) (stringp qpat)) - (destructuring-bind (then-rest &rest else-rest) - (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest) + (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--u1 matches code vars then-rest) (pcase--u else-rest)))) |