[Emacs-diffs] trunk r117827: Add vector qpattern to pcase

[Leo Liu]

------------------------------------------------------------
revno: 117827
revision-id: address@hidden
parent: address@hidden
fixes bug: http://debbugs.gnu.org/18327
committer: Leo Liu <address@hidden>
branch nick: trunk
timestamp: Sat 2014-09-06 08:59:00 +0800
message:
  Add vector qpattern to pcase
  
  * doc/lispref/control.texi (Pattern matching case statement): Document vector
  qpattern. 
  
  * etc/NEWS: Mention vector qpattern for pcase.  (Bug#18327).
  
  * lisp/emacs-lisp/pcase.el (pcase): Doc fix.
  (pcase--split-vector): New function.
  (pcase--q1): Support vector qpattern.  (Bug#18327)
modified:
  doc/lispref/ChangeLog          changelog-20091113204419-o5vbwnq5f7feedwu-6155
  doc/lispref/control.texi       
control.texi-20091113204419-o5vbwnq5f7feedwu-6169
  etc/ChangeLog                  changelog-20091113204419-o5vbwnq5f7feedwu-1485
  etc/NEWS                       news-20100311060928-aoit31wvzf25yr1z-1
  lisp/ChangeLog                 changelog-20091113204419-o5vbwnq5f7feedwu-1432
  lisp/emacs-lisp/pcase.el       pcase.el-20100810123717-8zwve3391p2ywm1h-1

=== modified file 'doc/lispref/ChangeLog'
--- a/doc/lispref/ChangeLog     2014-08-29 11:02:56 +0000
+++ b/doc/lispref/ChangeLog     2014-09-06 00:59:00 +0000
@@ -1,3 +1,8 @@
+2014-09-06  Leo Liu  <address@hidden>
+
+       * control.texi (Pattern matching case statement): Document vector
+       qpattern.  (Bug#18327)
+
 2014-08-29  Dmitry Antipov  <address@hidden>
 
        * lists.texi (Functions that Rearrange Lists): Remove

=== modified file 'doc/lispref/control.texi'
--- a/doc/lispref/control.texi  2014-01-24 04:11:48 +0000
+++ b/doc/lispref/control.texi  2014-09-06 00:59:00 +0000
@@ -370,6 +370,10 @@
 @item (@var{qpattern1} . @var{qpattern2})
 This pattern matches any cons cell whose @code{car} matches @var{QPATTERN1} and
 whose @code{cdr} matches @var{PATTERN2}.
address@hidden address@hidden qpattern2..qpatternm}]
+This pattern matches a vector of length @code{M} whose 0..(M-1)th
+elements match @var{QPATTERN1}, @address@hidden,
+respectively.
 @item @var{atom}
 This pattern matches any atom @code{equal} to @var{atom}.
 @item ,@var{upattern}

=== modified file 'etc/ChangeLog'
--- a/etc/ChangeLog     2014-09-01 14:57:21 +0000
+++ b/etc/ChangeLog     2014-09-06 00:59:00 +0000
@@ -1,3 +1,7 @@
+2014-09-06  Leo Liu  <address@hidden>
+
+       * NEWS: Mention vector qpattern for pcase.  (Bug#18327).
+
 2014-09-01  Eli Zaretskii  <address@hidden>
 
        * NEWS: Mention that ls-lisp uses string-collate-lessp.

=== modified file 'etc/NEWS'
--- a/etc/NEWS  2014-09-05 19:07:52 +0000
+++ b/etc/NEWS  2014-09-06 00:59:00 +0000
@@ -107,6 +107,9 @@
 *** C-x C-x in rectangle-mark-mode now cycles through the four corners.
 *** `string-rectangle' provides on-the-fly preview of the result.
 
++++
+** Macro `pcase' now supports vector qpattern.
+
 ** New font-lock functions font-lock-ensure and font-lock-flush, which
 should be used instead of font-lock-fontify-buffer when called from Elisp.
 

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2014-09-05 19:07:52 +0000
+++ b/lisp/ChangeLog    2014-09-06 00:59:00 +0000
@@ -1,3 +1,9 @@
+2014-09-06  Leo Liu  <address@hidden>
+
+       * emacs-lisp/pcase.el (pcase): Doc fix.
+       (pcase--split-vector): New function.
+       (pcase--q1): Support vector qpattern.  (Bug#18327)
+
 2014-09-05  Sam Steingold  <address@hidden>
 
        * textmodes/tex-mode.el (tex-print-file-extension): New user

=== modified file 'lisp/emacs-lisp/pcase.el'
--- a/lisp/emacs-lisp/pcase.el  2014-01-03 04:40:30 +0000
+++ b/lisp/emacs-lisp/pcase.el  2014-09-06 00:59:00 +0000
@@ -108,11 +108,12 @@
 \"non-linear\"), then the second occurrence is turned into an `eq'uality test.
 
 QPatterns can take the following forms:
-  (QPAT1 . QPAT2)      matches if QPAT1 matches the car and QPAT2 the cdr.
-  ,UPAT                        matches if the UPattern UPAT matches.
-  STRING               matches if the object is `equal' to STRING.
-  ATOM                 matches if the object is `eq' to ATOM.
-QPatterns for vectors are not implemented yet.
+  (QPAT1 . QPAT2)       matches if QPAT1 matches the car and QPAT2 the cdr.
+  [QPAT1 QPAT2..QPATn]  matches a vector of length n and QPAT1..QPATn match
+                           its 0..(n-1)th elements, respectively.
+  ,UPAT                 matches if the UPattern UPAT matches.
+  STRING                matches if the object is `equal' to STRING.
+  ATOM                  matches if the object is `eq' to ATOM.
 
 PRED can take the form
   FUNCTION          in which case it gets called with one argument.
@@ -447,6 +448,24 @@
          (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.
@@ -738,8 +757,30 @@
    ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
    ((floatp qpat) (error "Floating point patterns not supported"))
    ((vectorp qpat)
-    ;; FIXME.
-    (error "Vector QPatterns not implemented yet"))
+    (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)
+                                     `(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))))
    ((consp qpat)
     (let* ((syma (make-symbol "xcar"))
            (symd (make-symbol "xcdr"))