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

[Leo Liu]

Hi Stefan,

The attached patch (inspired by your byte-code-function qpattern patch)
seems to add vector QPattern to pcase. Could you review it and give me
any comments? Thanks.

I haven't wanted vector qpattern badly enough until just now having put
up with many many:

     (and (pred vectorp) io
          (let `(io_request ,from ,replyas ,request)
            (cl-coerce io 'list)))

which is both ugly and inefficient.

Thanks,
Leo

=== 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-08-25 07:52:34 +0000
@@ -54,6 +54,7 @@
 ;;; Code:
 
 (require 'macroexp)
+(eval-when-compile (require 'cl-lib))
 
 ;; 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
@@ -447,6 +448,22 @@
          (pcase--mutually-exclusive-p #'consp (cadr pat)))
     '(:pcase--fail . nil))))
 
+(defun pcase--split-vector (len syms pat)
+  (cond
+   ;; A QPattern for a vector of same length
+   ((and (eq (car-safe pat) '\`)
+         (vectorp (cadr pat))
+         (= len (length (cadr pat))))
+    (let ((qpat (cadr pat)))
+      (cons `(and ,@(cl-loop for s in syms for i from 0
+                             collect `(match ,s . ,(pcase--upat (aref qpat 
i)))))
+            :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 +755,27 @@
    ((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) (make-symbol (format "xaref%s" i)))
+                         (number-sequence 0 (1- len))))
+           (splitrest (pcase--split-rest
+                       sym
+                       (lambda (pat) (pcase--split-vector len syms pat))
+                       rest))
+           (then-rest (car splitrest))
+           (else-rest (cdr splitrest))
+           (then-body (pcase--u1
+                       `(,@(cl-loop for s in syms for i from 0
+                                    collect `(match ,s . ,(pcase--upat (aref 
qpat i))))
+                         ,@matches)
+                       code vars then-rest)))
+      (pcase--if
+       `(and (vectorp ,sym) (= (length ,sym) ,len))
+       (macroexp-let*
+        (cl-loop for s in syms for i from 0
+                 when (get s 'pcase-used) collect `(,s (aref ,sym ,i)))
+        then-body)
+       (pcase--u else-rest))))
    ((consp qpat)
     (let* ((syma (make-symbol "xcar"))
            (symd (make-symbol "xcdr"))