Function: pcase--u1
pcase--u1 is a byte-compiled function defined in pcase.el.gz.
Signature
(pcase--u1 MATCHES CODE VARS REST)
Documentation
Return code that runs CODE (with VARS) if MATCHES match.
Otherwise, it defers to REST which is a list of branches of the form
(ELSE-MATCH ELSE-CODE . ELSE-VARS).
Source Code
;; Defined in /usr/src/emacs/lisp/emacs-lisp/pcase.el.gz
;; It's very tempting to use `pcase' below, tho obviously, it'd create
;; bootstrapping problems.
(defun pcase--u1 (matches code vars rest)
"Return code that runs CODE (with VARS) if MATCHES match.
Otherwise, it defers to REST which is a list of branches of the form
\(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
;; Depending on the order in which we choose to check each of the MATCHES,
;; the resulting tree may be smaller or bigger. So in general, we'd want
;; to be careful to choose the "optimal" order. But predicate
;; patterns make this harder because they create dependencies
;; between matches. So we don't bother trying to reorder anything.
(cond
((null matches) (funcall code vars))
((eq :pcase--fail (car matches)) (pcase--u rest))
((eq :pcase--succeed (car matches))
(pcase--u1 (cdr matches) code vars rest))
((eq 'and (caar matches))
(pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
((eq 'or (caar matches))
(let* ((alts (cdar matches))
(var (if (eq (caar alts) 'match) (cadr (car alts))))
(simples '()) (others '()) (mem-fun 'memq))
(when var
(dolist (alt alts)
(if (and (eq (car alt) 'match) (eq var (cadr alt))
(let ((upat (cddr alt)))
(eq (car-safe upat) 'quote)))
(let ((val (cadr (cddr alt))))
(cond ((integerp val)
(when (eq mem-fun 'memq)
(setq mem-fun 'memql)))
((not (symbolp val))
(setq mem-fun 'member)))
(push val simples))
(push alt others))))
(cond
((null alts) (error "Please avoid it") (pcase--u rest))
;; Yes, we can use `memql' (or `member')!
((> (length simples) 1)
(pcase--u1 (cons `(match ,var
. (pred (pcase--flip ,mem-fun ',simples)))
(cdr matches))
code vars
(if (null others) rest
(cons (cons
(pcase--and (if (cdr others)
(cons 'or (nreverse others))
(car others))
(cdr matches))
(cons code vars))
rest))))
(t
(pcase--u1 (cons (pop alts) (cdr matches)) code vars
(if (null alts) (progn (error "Please avoid it") rest)
(cons (cons
(pcase--and (if (cdr alts)
(cons 'or alts) (car alts))
(cdr matches))
(cons code vars))
rest)))))))
((eq 'match (caar matches))
(let* ((popmatches (pop matches))
(_op (car popmatches)) (cdrpopmatches (cdr popmatches))
(sym (car cdrpopmatches))
(upat (cdr cdrpopmatches)))
(cond
((memq upat '(t _))
(let ((code (pcase--u1 matches code vars rest)))
(if (eq upat '_) code
(macroexp-warn-and-return
"Pattern t is deprecated. Use `_' instead"
code))))
((eq upat 'pcase--dontcare) :pcase--dontcare)
((memq (car-safe upat) '(guard pred))
(if (eq (car upat) 'pred) (pcase--mark-used sym))
(let* ((splitrest
(pcase--split-rest
sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
(pcase--if (if (eq (car upat) 'pred)
(pcase--funcall (cadr upat) sym vars)
(pcase--eval (cadr upat) vars))
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
((and (symbolp upat) upat)
(pcase--mark-used sym)
(let ((v (assq upat vars)))
(if (not v)
(pcase--u1 matches code (cons (list upat sym) vars) rest)
;; Non-linear pattern. Turn it into an `eq' test.
(setcdr (cdr v) 'used)
(pcase--u1 (cons `(match ,sym . (pred (eql ,(cadr v))))
matches)
code vars rest))))
((eq (car-safe upat) 'app)
;; A upat of the form (app FUN PAT)
(pcase--mark-used sym)
(let* ((fun (nth 1 upat))
(nsym (gensym "x"))
(body
;; We don't change `matches' to reuse the newly computed value,
;; because we assume there shouldn't be such redundancy in there.
(pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches)
code vars
(pcase--app-subst-rest rest sym fun nsym))))
(if (not (get nsym 'pcase-used))
body
(macroexp-let*
`((,nsym ,(pcase--funcall fun sym vars)))
body))))
((eq (car-safe upat) 'quote)
(pcase--mark-used sym)
(let* ((val (cadr upat))
(splitrest (pcase--split-rest
sym (lambda (pat) (pcase--split-equal val pat)) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
(pcase--if (cond
((null val) `(null ,sym))
((integerp val) `(eql ,sym ,val))
((symbolp val)
(if (pcase--self-quoting-p val)
`(eq ,sym ,val)
`(eq ,sym ',val)))
(t `(equal ,sym ',val)))
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
((eq (car-safe upat) 'not)
;; FIXME: The implementation below is naive and results in
;; inefficient code.
;; To make it work right, we would need to turn pcase--u1's
;; `code' and `vars' into a single argument of the same form as
;; `rest'. We would also need to split this new `then-rest' argument
;; for every test (currently we don't bother to do it since
;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
;; `(PAT3 . PAT4)) which the programmer can easily rewrite
;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
(pcase--u1 `((match ,sym . ,(cadr upat)))
;; 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 pattern `%S'" upat)))))
(t (error "Incorrect MATCH %S" (car matches)))))