[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#18327: 24.4.50; [PATCH] vector QPattern for pcase
From: |
Leo Liu |
Subject: |
bug#18327: 24.4.50; [PATCH] vector QPattern for pcase |
Date: |
Mon, 25 Aug 2014 16:02:26 +0800 |
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"))
- bug#18327: 24.4.50; [PATCH] vector QPattern for pcase,
Leo Liu <=