* lisp/emacs-lisp/pcase.el: Use pcase-defmacro to handle backquote.

(pcase--upat): Remove.
(pcase--macroexpand): Don't hardcode handling of `.
(pcase--split-consp, pcase--split-vector): Remove.
(pcase--split-equal): Disregard ` since it's expanded away.
(pcase--split-member): Optimize for quote rather than for `.
(pcase--split-pred): Optimize for quote rather than for `.
(pcase--u1): Remove handling of ` (and of `or' and `and').
Quote non-selfquoting values when passing them to `eq'.
Drop `app's let-binding if the variable is not used.
(pcase--q1): Remove.
(`): Define as a pattern macro.

2 files changed, 61 insertions, 147 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ea09a9afa7b..6f8178a9a4c 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,18 @@
 2014-09-22  Stefan Monnier  <monnier@iro.umontreal.ca>
 
+	* emacs-lisp/pcase.el: Use pcase-defmacro to handle backquote.
+	(pcase--upat): Remove.
+	(pcase--macroexpand): Don't hardcode handling of `.
+	(pcase--split-consp, pcase--split-vector): Remove.
+	(pcase--split-equal): Disregard ` since it's expanded away.
+	(pcase--split-member): Optimize for quote rather than for `.
+	(pcase--split-pred): Optimize for quote rather than for `.
+	(pcase--u1): Remove handling of ` (and of `or' and `and').
+	Quote non-selfquoting values when passing them to `eq'.
+	Drop `app's let-binding if the variable is not used.
+	(pcase--q1): Remove.
+	(`): Define as a pattern macro.
+
 	* emacs-lisp/pcase.el (pcase--match): New smart-constructor function.
 	(pcase--expand pcase--q1, pcase--app-subst-match): Use it.
 	(pcase--macroexpand): Handle self-quoting patterns here, expand them to
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index cfbe63e073f..e17088ac9f2 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -309,7 +309,7 @@ of the form (UPAT EXP)."
     (cond
      ((null head)
       (if (pcase--self-quoting-p pat) `',pat pat))
-     ((memq head '(pred guard quote \`)) pat)
+     ((memq head '(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))))
@@ -365,11 +365,6 @@ of the form (UPAT EXP)."
    ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
    (t (macroexp-if test then else))))
 
-(defun pcase--upat (qpattern)
-  (cond
-   ((eq (car-safe qpattern) '\,) (cadr qpattern))
-   (t (list '\` qpattern))))
-
 ;; Note about MATCH:
 ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
 ;; check, we want to turn all the similar patterns into ones of the form
@@ -483,45 +478,13 @@ MATCH is the pattern that needs to be matched, of the form:
           (push (cons (cdr split) code&vars) else-rest))))
     (cons (nreverse then-rest) (nreverse else-rest))))
 
-(defun pcase--split-consp (syma symd pat)
-  (cond
-   ;; A QPattern for a cons, can only go the `then' side.
-   ((and (eq (car-safe pat) '\`) (consp (cadr pat)))
-    (let ((qpat (cadr pat)))
-      (cons `(and ,(pcase--match syma (pcase--upat (car qpat)))
-                  ,(pcase--match symd (pcase--upat (cdr qpat))))
-            :pcase--fail)))
-   ;; A QPattern but not for a cons, can only go to the `else' side.
-   ((eq (car-safe pat) '\`) '(:pcase--fail . nil))
-   ((and (eq (car-safe pat) 'pred)
-         (pcase--mutually-exclusive-p #'consp (cadr pat)))
-    '(:pcase--fail . nil))))
-
-(defun pcase--split-vector (syms pat)
-  (cond
-   ;; A QPattern for a vector of same length.
-   ((and (eq (car-safe pat) '\`)
-         (vectorp (cadr pat))
-         (= (length syms) (length (cadr pat))))
-    (let ((qpat (cadr pat)))
-      (cons `(and ,@(mapcar (lambda (s)
-                              `(match ,(car s) .
-                                      ,(pcase--upat (aref qpat (cdr s)))))
-                            syms))
-            :pcase--fail)))
-   ;; Other QPatterns go to the `else' side.
-   ((eq (car-safe pat) '\`) '(:pcase--fail . nil))
-   ((and (eq (car-safe pat) 'pred)
-         (pcase--mutually-exclusive-p #'vectorp (cadr pat)))
-    '(:pcase--fail . nil))))
-
 (defun pcase--split-equal (elem pat)
   (cond
    ;; The same match will give the same result.
-   ((and (memq (car-safe pat) '(quote \`)) (equal (cadr pat) elem))
+   ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem))
     '(:pcase--succeed . :pcase--fail))
    ;; A different match will fail if this one succeeds.
-   ((and (memq (car-safe pat) '(quote \`))
+   ((and (eq (car-safe pat) 'quote)
          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
          ;;     (consp (cadr pat)))
          )
@@ -535,6 +498,7 @@ MATCH is the pattern that needs to be matched, of the form:
 	'(:pcase--fail . nil))))))
 
 (defun pcase--split-member (elems pat)
+  ;; FIXME: The new pred-based member code doesn't do these optimizations!
   ;; Based on pcase--split-equal.
   (cond
    ;; The same match (or a match of membership in a superset) will
@@ -542,10 +506,10 @@ MATCH is the pattern that needs to be matched, of the form:
    ;; (???
    ;;  '(:pcase--succeed . nil))
    ;; A match for one of the elements may succeed or fail.
-   ((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
+   ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems))
     nil)
    ;; A different match will fail if this one succeeds.
-   ((and (eq (car-safe pat) '\`)
+   ((and (eq (car-safe pat) 'quote)
          ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
          ;;     (consp (cadr pat)))
          )
@@ -576,7 +540,7 @@ MATCH is the pattern that needs to be matched, of the form:
      ((and (eq 'pred (car upat))
            (let ((otherpred
                   (cond ((eq 'pred (car-safe pat)) (cadr pat))
-                        ((not (eq '\` (car-safe pat))) nil)
+                        ((not (eq 'quote (car-safe pat))) nil)
                         ((consp (cadr pat)) #'consp)
                         ((vectorp (cadr pat)) #'vectorp)
                         ((byte-code-function-p (cadr pat))
@@ -584,7 +548,7 @@ MATCH is the pattern that needs to be matched, of the form:
              (pcase--mutually-exclusive-p (cadr upat) otherpred)))
       '(:pcase--fail . nil))
      ((and (eq 'pred (car upat))
-           (eq '\` (car-safe pat))
+           (eq 'quote (car-safe pat))
            (symbolp (cadr upat))
            (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
            (get (cadr upat) 'side-effect-free)
@@ -762,25 +726,28 @@ Otherwise, it defers to REST which is a list of branches of the form
        ((eq (car-safe upat) 'app)
         ;; A upat of the form (app FUN UPAT)
         (pcase--mark-used sym)
-        (let* ((fun (nth 1 upat)))
-          (macroexp-let2
-              macroexp-copyable-p nsym
-              (if (symbolp fun)
-                  `(,fun ,sym)
-                (let* ((vs (pcase--fgrep (mapcar #'car vars) fun))
-                       (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
-                                    vs))
-                       (call `(funcall #',fun ,sym)))
-                  (if env (macroexp-let* env call) call)))
-            ;; 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)))))
-       ((eq (car-safe upat) '\`)
-        (pcase--mark-used sym)
-        (pcase--q1 sym (cadr upat) matches code vars rest))
+        (let* ((fun (nth 1 upat))
+               (nsym (make-symbol "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
+                ,(if (symbolp fun)
+                     `(,fun ,sym)
+                   (let* ((vs (pcase--fgrep (mapcar #'car vars) fun))
+                          (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
+                                       vs))
+                          (call `(funcall #',fun ,sym)))
+                     (if env (macroexp-let* env call) call)))))
+             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))
@@ -788,24 +755,13 @@ Otherwise, it defers to REST which is a list of branches of the form
                (else-rest (cdr splitrest)))
           (pcase--if (cond
                       ((null val) `(null ,sym))
-                      ((or (integerp val) (symbolp val)) `(eq ,sym ,val))
+                      ((or (integerp 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) 'or)
-        (error "Should have been hoisted already: %S" upat)
-        (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
-                   (append (mapcar (lambda (upat)
-                                     `((and (match ,sym . ,upat) ,@matches)
-                                       ,code ,@vars))
-                                   (cddr upat))
-                           rest)))
-       ((eq (car-safe upat) 'and)
-        (error "Should have been hoisted already: %S" upat)
-        (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat))
-                                   (cdr upat))
-                           matches)
-                   code vars rest))
        ((eq (car-safe upat) 'not)
         ;; FIXME: The implementation below is naive and results in
         ;; inefficient code.
@@ -827,80 +783,25 @@ Otherwise, it defers to REST which is a list of branches of the form
                      (pcase--u rest))
                    vars
                    (list `((and . ,matches) ,code . ,vars))))
-       (t (error "Unknown upattern `%s'" upat)))))
-   (t (error "Incorrect MATCH %s" (car matches)))))
+       (t (error "Unknown internal pattern `%S'" upat)))))
+   (t (error "Incorrect MATCH %S" (car matches)))))
 
-(defun pcase--q1 (sym qpat matches code vars rest)
-  "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
-Otherwise, it defers to REST which is a list of branches of the form
-\(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
+(pcase-defmacro \` (qpat)
   (cond
-   ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
-   ((floatp qpat) (error "Floating point patterns not supported"))
+   ((eq (car-safe qpat) '\,) (cadr qpat))
    ((vectorp qpat)
-    (let* ((len (length qpat))
-           (syms (mapcar (lambda (i) (cons (make-symbol (format "xaref%s" i)) i))
-                         (number-sequence 0 (1- len))))
-           (splitrest (pcase--split-rest
-                       sym
-                       (lambda (pat) (pcase--split-vector syms pat))
-                       rest))
-           (then-rest (car splitrest))
-           (else-rest (cdr splitrest))
-           (then-body (pcase--u1
-                       `(,@(mapcar (lambda (s)
-                                     (pcase--match
-                                      (car s)
-                                      (pcase--upat (aref qpat (cdr s)))))
-                                   syms)
-                         ,@matches)
-                       code vars then-rest)))
-      (pcase--if
-       `(and (vectorp ,sym) (= (length ,sym) ,len))
-       (macroexp-let* (delq nil (mapcar (lambda (s)
-                                          (and (get (car s) 'pcase-used)
-                                               `(,(car s) (aref ,sym ,(cdr s)))))
-                                        syms))
-                      then-body)
-       (pcase--u else-rest))))
+    `(and (pred vectorp)
+          (app length ,(length qpat))
+          ,@(let ((upats nil))
+              (dotimes (i (length qpat))
+                (push `(app (lambda (v) (aref v ,i)) ,(list '\` (aref qpat i)))
+                      upats))
+              (nreverse upats))))
    ((consp qpat)
-    (let* ((syma (make-symbol "xcar"))
-           (symd (make-symbol "xcdr"))
-           (splitrest (pcase--split-rest
-                       sym
-                       (lambda (pat) (pcase--split-consp syma symd pat))
-                       rest))
-           (then-rest (car splitrest))
-           (else-rest (cdr splitrest))
-           (then-body (pcase--u1 `(,(pcase--match syma (pcase--upat (car qpat)))
-                                   ,(pcase--match symd (pcase--upat (cdr qpat)))
-                                   ,@matches)
-                                 code vars then-rest)))
-      (pcase--if
-       `(consp ,sym)
-       ;; We want to be careful to only add bindings that are used.
-       ;; 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.
-       ;; FIXME: Some of those let bindings occur too early (they are used in
-       ;; `then-body', but only within some sub-branch).
-       (macroexp-let*
-        `(,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
-          ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
-        then-body)
-       (pcase--u else-rest))))
-   ((or (integerp qpat) (symbolp qpat) (stringp qpat))
-    (let* ((splitrest (pcase--split-rest
-                       sym (lambda (pat) (pcase--split-equal qpat pat)) rest))
-           (then-rest (car splitrest))
-           (else-rest (cdr splitrest)))
-      (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))))
+    `(and (pred consp)
+          (app car ,(list '\` (car qpat)))
+          (app cdr ,(list '\` (cdr qpat)))))
+   ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat)))
 
 
 (provide 'pcase)