bug#18327: 24.4.50; [PATCH] vector QPattern for pcase

[Leo Liu <sdl.web@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 740 bytes --]

On 2014-09-04 12:21 -0400, Stefan Monnier wrote:
> Please double-check that it doesn't break bootstrap (CL uses pcase as
> well, and I have some vague recollection of bumping into problems in
> this area, which is why pcase doesn't use CL).

Indeed, that failed to bootstrap. I get rid of cl-loop.

> Also the patch needs to update pcase's docstring (based on my
> understanding of your code, you only handle qpatterns of the form
> [QPAT1..QPATn], right?).

Yes, it only handles fixed-size vector qpatterns. Having built this
simpler one your byte-code qpattern patch makes a lot more sense to me.
And the `...' notation looks cool.

For the packages I am writing fixed-size qpattern is more than enough ;)

>         Stefan

Thanks,
Leo


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pcase-vector-qpat2.diff --]
[-- Type: text/x-patch, Size: 3423 bytes --]

=== modified file 'lisp/emacs-lisp/pcase.el'
--- lisp/emacs-lisp/pcase.el	2014-01-03 04:40:30 +0000
+++ lisp/emacs-lisp/pcase.el	2014-09-04 17:16:34 +0000
@@ -108,11 +108,11 @@
 \"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]         matches if QPAT1/2 match the first/second elements
+  ,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 +447,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 +756,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"))