commit 26bd8b4fb9175dd554a634c16bc3f7b1eb4e30c2
parent 017f4e0d02fc4cc1605b3e99994892a62848a272
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Sat, 6 Nov 2010 23:42:43 +0100
Import de ma version de match
Diffstat:
| M | match.lisp | | | 640 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------------- |
1 file changed, 522 insertions(+), 118 deletions(-)
diff --git a/match.lisp b/match.lisp
@@ -33,59 +33,54 @@
;; Dans le cas où le pattern n'est pas "simple", la valeur correspondante
;; sera une liste de toutes les occurences de pattern
-(defun pattern-match-do-lambdas-? (pattern)
+(defun pattern-match-do-lambdas-transform (pattern)
(mapcar (lambda (pred)
- (cond ((atom pred) (list 'quote pred))
+ (cond ((atom pred) (list 'function pred))
((eq (car pred) 'function) pred)
((eq (car pred) 'lambda) pred)
(t
`(lambda (x) ,pred))))
(cdr pattern)))
-(defmacro pattern-match-do-lambdas (pattern)
- "Transforme les (? x <code>) et (? (lambda ...)) en vrais lambdas."
- (cond
- ;; (? x <code>)
- ((and (n-consp 2 pattern)
- (eq '? (first pattern)))
- (cond ((eq 'and (second pattern)) `(list '? 'and ,@(pattern-match-do-lambdas-? (cdr pattern))))
- ((eq 'or (second pattern)) `(list '? 'or ,@(pattern-match-do-lambdas-? (cdr pattern))))
- (t `(list '? 'and ,@(pattern-match-do-lambdas-? pattern)))))
- ;; (p1 p2 ... pn)
- ((consp pattern)
- ;; Transformation de chaque pattern de la liste y compris
- ;; le dernier cdr si ce n'est pas nil.
- (labels ((recurse (pat)
- (cond ((null pat) nil)
- ((atom pat) `(pattern-match-do-lambdas ,pat))
- (t `(cons (pattern-match-do-lambdas ,(car pat))
- ,(recurse (cdr pat)))))))
- (recurse pattern)))
- ;; Autres cas
- (t
- (list 'quote pattern))))
-(defun transform (pat)
- (let ((str-sym (string pat)))
- (if (< (length str-sym) 2)
- pat
- (let* ((sym (map 'list #'identity str-sym))
- (lsym (car (last sym))))
- (if (or (char= lsym #\*)
- (char= lsym #\+)
- (char= lsym #\?))
- (list (intern (format nil "~{~a~}" (butlast sym)))
- (intern (string lsym)))
- pat)))))
+(defun pattern-match-do-lambdas-1 (pattern)
+ (if (atom pattern)
+ `',pattern
+ `(list ',(first pattern)
+ ',(second pattern)
+ ,(if (second pattern)
+ (let ((?-clause (third pattern)))
+ (cond ((atom (cdr ?-clause)) `(list 'and #'identity))
+ ((eq 'and (second ?-clause)) `(list 'and ,@(pattern-match-do-lambdas-transform (cdr ?-clause))))
+ ((eq 'or (second ?-clause)) `(list 'or ,@(pattern-match-do-lambdas-transform (cdr ?-clause))))
+ (t `(list 'and ,@(pattern-match-do-lambdas-transform ?-clause)))))
+ (pattern-match-do-lambdas-1 (third pattern)))
+ ',(fourth pattern)
+ ,(pattern-match-do-lambdas-1 (fifth pattern)))))
-;; TODO : peut-être virer cette fonction, elle est *très* moche
-;; et pas très utile.
-(defun pattern-match-preprocess (pattern)
+(defmacro pattern-match-do-lambdas (pattern)
+ "Transforme les (? (<code>)) et (? (lambda ...)) en vrais lambdas."
+ (pattern-match-do-lambdas-1 pattern))
+
+(defun transform-symbol-to-multi (pat)
+ (let ((str-sym (string pat)))
+ (if (< (length str-sym) 2)
+ pat
+ (let* ((sym (map 'list #'identity str-sym))
+ (lsym (car (last sym))))
+ (if (or (char= lsym #\*)
+ (char= lsym #\+)
+ (char= lsym #\?))
+ (list (intern (format nil "~{~a~}" (butlast sym)))
+ (intern (string lsym)))
+ pat)))))
+
+(defun pattern-match-preprocess-multi (pattern)
"Transforme les symbol*, symbol+ et symbol?
en symbol *, symbol + et symbol ?"
(cond ((and (consp pattern) (eq '? (first pattern)))
pattern) ;; On ne touche pas les (? ...)
((consp pattern)
- (labels ((transform (pat)
+ (labels ((transform-symbol-to-multi (pat)
(let ((str-sym (string pat)))
(if (< (length str-sym) 2)
pat
@@ -100,97 +95,308 @@
(recurse (pat)
(cond
((null pat) nil)
- ((symbolp pat) (transform pat))
+ ((symbolp pat) (transform-symbol-to-multi pat))
((atom pat) pat)
+ ((keywordp (car pat)) ;; TODO : non testé !!!
+ `(,(car pat)
+ ,@(recurse (cdr pat))))
((symbolp (car pat))
- (let ((transf (transform (car pat))))
+ (let ((transf (transform-symbol-to-multi (car pat))))
(if (consp transf)
`(,@transf ,@(recurse (cdr pat)))
`(,transf ,@(recurse (cdr pat))))))
- (t (cons (pattern-match-preprocess (car pat))
+ (t (cons (pattern-match-preprocess-multi (car pat))
(recurse (cdr pat)))))))
(recurse pattern)))
+ ((symbolp pattern)
+ (transform-symbol-to-multi pattern))
(t
pattern)))
-(defun pattern-match (pattern expr)
- (cond
- ;; (pattern * ...)
- ((and (n-consp 2 pattern) (eq '* (second pattern)))
- (or (pattern-match (cddr pattern) expr)
- (and (consp expr)
- (pattern-match (car pattern) (car expr))
- (pattern-match pattern (cdr expr)))))
- ;; (pattern + ...)
- ((and (n-consp 2 pattern) (eq '+ (second pattern)))
- (and (consp expr)
- (pattern-match (first pattern) (car expr))
- (pattern-match `(,(first pattern) * ,@(cddr pattern)) (cdr expr))))
- ;; (pattern ? ...)
- ((and (n-consp 2 pattern) (eq '? (second pattern)))
- (or (and (consp expr)
- (pattern-match (first pattern) (car expr))
- (pattern-match (cddr pattern) (cdr expr)))
- (pattern-match (cddr pattern) expr)))
- ;; (? <prédicat(s)>)
- ((and (n-consp 2 pattern) (eq '? (first pattern)))
- (cond
- ;; (? and symbole-1 ... symbole-n)
- ((eq 'and (second pattern))
- (every (lambda (predicat) (funcall predicat expr)) (cddr pattern)))
- ;; (? or symbole-1 ... symbole-n)
- ((eq 'or (second pattern))
- (some (lambda (predicat) (funcall predicat expr)) (cddr pattern)))
- ;; (? (lambda (x) <code>))
- ((functionp (second pattern))
- (funcall (second pattern) expr)) ;; niy
- ;; (? symbole)
- ((symbolp (second pattern))
- (funcall (second pattern) expr))
- (t
- (error "Motif malformé."))))
- ;; (pattern . rest)
- ((consp pattern)
- (and (consp expr)
- (pattern-match (car pattern) (car expr))
- (pattern-match (cdr pattern) (cdr expr))))
- ;; ()
- ((null pattern)
- (null expr))
- ;; $
- ((eq '$ pattern)
- (and (atom expr)
- (not (null expr))))
- ;; @
- ((eq '@ pattern)
- (or (null expr)
- (and (consp expr)
- (pattern-match '@ (cdr expr)))))
- ;; @.
- ((eq '@. pattern)
- (consp expr))
- ;; _
- ((eq '_ pattern)
- t)
- ;; :symbole
- ((and (consp pattern) (keywordp (car pattern)))
- "niy")
- ;; symbole
- ((symbolp pattern)
- (eq pattern expr))
- ;; Autres valeurs
- (t
- (equal pattern expr))))
-
-(defmacro match (pattern expr)
- `(pattern-match
- (pattern-match-preprocess
- (pattern-match-do-lambdas ,pattern))
- ,expr))
+(defun keyword-to-symbol (keyword)
+ (intern (format nil "~a" keyword)))
+
+(defun pattern-match-preprocess-capture (pattern &optional capture-name)
+ "Transforme pattern en un arbre (capture-name is-predicate pattern multi rest)."
+ (if (and (consp pattern) (keywordp (car pattern)))
+ ;; capture-name
+ (if (and (n-consp 2 (cdr pattern)) (member (caddr pattern) '(* + ?)))
+ ;; avec capture-name, avec multi
+ (list (keyword-to-symbol capture-name)
+ nil
+ (pattern-match-preprocess-capture (second pattern) (first pattern))
+ (third pattern)
+ (pattern-match-preprocess-capture (cdddr pattern)))
+ ;; avec capture-name, sans multi
+ (cond
+ ;; (:x . a)
+ ((atom (cdr pattern))
+ (list (keyword-to-symbol (car pattern))
+ nil
+ (cdr pattern)
+ nil
+ nil))
+ ;; (:x . (? ...))
+ ((and (consp pattern) (eq '? (cadr pattern)))
+ (list (keyword-to-symbol (car pattern))
+ t
+ (cdr pattern)
+ nil
+ nil)) ;; TODO
+ ;; (:x cadr-pattern . cddr-pattern)
+ (t
+ (list (keyword-to-symbol capture-name)
+ nil
+ (pattern-match-preprocess-capture (cadr pattern) (car pattern))
+ nil
+ (pattern-match-preprocess-capture (cddr pattern))))))
+ ;; pas de capture-name
+ (if (and (n-consp 2 pattern) (member (cadr pattern) '(* + ?)))
+ ;; sans capture-name, avec multi
+ (list (keyword-to-symbol capture-name)
+ nil
+ (pattern-match-preprocess-capture (first pattern))
+ (second pattern)
+ (pattern-match-preprocess-capture (cddr pattern)))
+ ;; sans capture-name, sans multi
+ (cond
+ ;; a
+ ((atom pattern)
+ (list (keyword-to-symbol capture-name)
+ nil
+ pattern
+ nil
+ nil))
+ ;; (? ...)
+ ((and (consp pattern) (eq '? (car pattern)))
+ (list (keyword-to-symbol capture-name)
+ t
+ pattern
+ nil
+ nil))
+ ;; (car-pattern . cdr-pattern)
+ (t
+ (list (keyword-to-symbol capture-name)
+ nil
+ (pattern-match-preprocess-capture (car pattern))
+ nil
+ (pattern-match-preprocess-capture (cdr pattern))))))))
+
+;; Fonctionnement du match avec *
+;;
+;; (match (:x (:y _ :z _)* :e _) '((a b) (1 2) (foo bar) x))
+;; ;; greedy match ok
+;; => ((:x (a b)) (:y a) (:z b)) ---> (match (:x (:y _ :z _)* :e _) '((1 2) (foo bar) x))
+;; [________________________] ;; greedy match ok
+;; | => ((:x (1 2)) (:y 1) (:z 2)) ---> (match (:x (:y _ :z _)* :e _) '((foo bar) x))
+;; | [________________________] ;; greedy match ok
+;; | | => ((:x (foo bar)) (:y foo) (:z bar)) ---> (match (:x (:y _ :z _)* :e _) '(x))
+;; | | [________________________________] ;; not greedy match !!!!
+;; | | | [ car = make-empty-matches ] [cdr = matches non-greedy ]
+;; | +-------------+ v => (((:x nil) (:y nil) (:z nil)) (:e x))
+;; | | [ --- param 1 = matches here --- ] ([ :x lst of rest of greedy ] [ matches non-greedy ])
+;; | | => (append-captures ((:x (foo bar)) (:y foo) (:z bar)) (((:x nil) (:y nil) (:z nil)) (:e x)))
+;; | | [ ---- greedy matches appended --------] [ matches non-greedy ]
+;; +-------------+ | => (((:x ((foo bar))) (:y (foo)) (:z (bar))) (:e x))
+;; | | [_______________________________________________]
+;; | v v
+;; | [________________________] [_______________________________________________]
+;; | => (append-captures ((:x (1 2)) (:y 1) (:z 2)) (((:x ((foo bar))) (:y (foo)) (:z (bar))) (:e x)))
+;; | => (((:x ((1 2) (foo bar))) (:y (1 foo)) (:z (2 bar))) (:e x))
+;; | [_________________________________________________________]
+;; v v
+;; [________________________] [_________________________________________________________]
+;; => (append-captures ((:x (a b)) (:y a) (:z b)) (((:x ((1 2) (foo bar))) (:y (1 foo)) (:z (2 bar))) (:e x)))
+;; => (((:x ((a b) (1 2) (foo bar))) (:y (a 1 foo)) (:z (b 2 bar))) (:e x))
+;; | |
+;; | first-multi = t |
+;; | => (append (car ___) (cdr ___)) |
+;; v v
+;; => ( (:x ((a b) (1 2) (foo bar))) (:y (a 1 foo)) (:z (b 2 bar)) (:e x))
+
+(defun append-captures-1 (captures-1 captures-2)
+ (if (endp captures-1)
+ nil
+ (if (caar captures-1) ;; ignorer les captures nommées nil
+ (cons (cons (caar captures-1) ;; nom de capture
+ (cons (cdar captures-1) ;; nouvelle capture
+ (cdr (assoc (caar captures-1) captures-2))))
+ (append-captures-1 (cdr captures-1) captures-2))
+ (append-captures-1 (cdr captures-1) captures-2))))
+
+(defun append-captures (captures-1 captures-2)
+ "captures-1 et 2 sont des alist nom-capture . arbre-capture
+ Renvoie une alist nom-capture . (append arbre-c1 arbre-c2)"
+ (cons (append-captures-1 captures-1 (car captures-2))
+ (cdr captures-2)))
+
+(defun make-empty-matches-1 (pattern result)
+ (if (atom pattern)
+ result
+ (let ((here (if (first pattern) ;; pas les captures nommées nil
+ (acons (first pattern) nil result)
+ result)))
+ (if (second pattern) ;; ne pas descendre dans les les (? ...)
+ here
+ (make-empty-matches-1 (fifth pattern)
+ (make-empty-matches-1 (third pattern) here))))))
+
+(defun make-empty-matches (pattern)
+ (reverse (make-empty-matches-1 pattern '())))
+
+(defun acons-capture (capture-name value captures)
+ (if (or capture-name (not captures))
+ (acons capture-name value captures)
+ captures))
+
+(defun append-car-cdr-not-nil (c)
+ (if (or (car c) (cdr c))
+ (append (car c) (cdr c))
+ (acons nil nil nil)))
+
+(defun append-not-nil-1 (a b)
+ (if (endp a)
+ b
+ (if (caar a)
+ (cons (car a) (append-not-nil-1 (cdr a) b))
+ (append-not-nil-1 (cdr a) b))))
+
+(defun append-not-nil (a b)
+ (or (append-not-nil-1 a b)
+ (acons nil nil nil)))
+
+(declaim (ftype function pattern-match)) ;; récursion mutuelle recursive-backtrack / pattern-match
+(defun recursive-backtrack (pattern rest expr capture-name)
+ (or
+ ;; match greedy (on avance dans le *)
+ (and (consp expr)
+ (let ((greedy-left (pattern-match pattern (car expr))))
+ (when greedy-left
+ (let ((greedy-right (recursive-backtrack pattern rest (cdr expr) capture-name)))
+ (when greedy-right
+ (append-captures (acons-capture capture-name (car expr) greedy-left)
+ greedy-right))))))
+ ;; match non-greedy (on match avec le rest)
+ (let ((non-greedy (pattern-match rest expr)))
+ (when non-greedy
+ (cons (acons-capture capture-name expr (make-empty-matches pattern))
+ non-greedy)))))
+
+(defun pattern-match (pat expr)
+ (let ((capture-name (first pat))
+ (is-predicate (second pat))
+ (pattern (third pat))
+ (multi (fourth pat))
+ (rest (fifth pat)))
+ (if multi
+ (if (not (listp expr))
+ nil
+ (cond
+ ;; (pattern * ...)
+ ((eq multi '*)
+ (let ((match (recursive-backtrack pattern rest expr capture-name)))
+ (when match
+ (append-car-cdr-not-nil match))))
+ ;; (pattern + ...)
+ ((eq multi '+)
+ (let ((first-match (and (consp expr) (pattern-match pattern (car expr)))))
+ (when first-match
+ (let ((match (recursive-backtrack pattern rest (cdr expr) capture-name)))
+ (when match
+ (let ((result (append-captures first-match match)))
+ (append-car-cdr-not-nil result)))))))
+ ;; (pattern ? ...)
+ ((eq multi '?)
+ (let ((match (and (consp expr) (pattern-match pattern (car expr)))))
+ (or (when match
+ (let ((match-rest (pattern-match rest (cdr expr))))
+ (when match-rest
+ (append match match-rest)))) ;; TODO : vérifier qu'on n'a pas besoin d'un make-empty-matches en cas de non-match de sous-trucs. (normalement non)
+ (let ((match-only-rest (pattern-match rest expr)))
+ (when match-only-rest
+ (append (acons-capture capture-name expr (make-empty-matches pattern))
+ match-only-rest))))))))
+ (if rest
+ ;; (pattern . rest)
+ (and (consp expr)
+ (let ((left (pattern-match pattern (car expr))))
+ (when left
+ (let ((right (pattern-match rest (cdr expr))))
+ (when right
+ (acons-capture capture-name expr (append-not-nil left right)))))))
+ ;; pattern est un atom
+ (cond
+ ;; (? <prédicat(s)>)
+ (is-predicate
+ (when (cond
+ ;; (? and symbole-1 ... symbole-n)
+ ((eq 'and (first pattern))
+ (every (lambda (predicat) (funcall predicat expr)) (cdr pattern)))
+ ;; (? or symbole-1 ... symbole-n)
+ ((eq 'or (first pattern))
+ (some (lambda (predicat) (funcall predicat expr)) (cdr pattern))))
+ (acons-capture capture-name expr nil)))
+ ;; ()
+ ((null pattern)
+ (when (null expr)
+ (acons-capture capture-name expr nil)))
+ ;; $
+ ((eq '$ pattern)
+ (when (and (atom expr)
+ (not (null expr)))
+ (acons-capture capture-name expr nil)))
+ ;; @
+ ((eq '@ pattern)
+ (when (propper-list-p expr)
+ (acons-capture capture-name expr nil)))
+ ;; @.
+ ((eq '@. pattern)
+ (when (consp expr)
+ (acons-capture capture-name expr nil)))
+ ;; _
+ ((eq '_ pattern)
+ (acons-capture capture-name expr nil))
+ ;; Autres valeurs (symbole, nombre, etc.)
+ (t
+ (when (equal pattern expr)
+ (acons-capture capture-name expr nil))))))))
+
+(defmacro pattern-match-preprocess (pattern)
+ "Tous les preprocess de pattern-match en un seul appel."
+ `(pattern-match-do-lambdas
+ ,(pattern-match-preprocess-capture
+ (pattern-match-preprocess-multi
+ pattern))))
+
+;; Attention ! le remove est un peu trop drastique s'il n'y a pas de capture, on renvoie nil quleque soit le résultat !
+(defmacro match (pattern expr &rest body)
+ (if (keywordp pattern)
+ `(match (,pattern . ,expr) ,(car body) ,@(cdr body))
+ (let* ((result-sym (make-symbol "result"))
+ (pattern-sym (make-symbol "pattern"))
+ (pattern-preproc (pattern-match-preprocess-capture
+ (pattern-match-preprocess-multi
+ pattern)))
+ (capture-names (mapcar #'car (make-empty-matches pattern-preproc))))
+ `(let* ((,pattern-sym (pattern-match-do-lambdas ,pattern-preproc))
+ (,result-sym (pattern-match ,pattern-sym ,expr)))
+ ;; Filtrage des captures nommées nil.
+ (when ,result-sym
+ (let ,(mapcar (lambda (x)
+ `(,x (cdr (assoc ',x ,result-sym))))
+ capture-names)
+ ;; "utilisation" des variables pour éviter les warning unused variable.
+ ,@(if body
+ (append capture-names body)
+ (if capture-names
+ `((list ,@capture-names))
+ `(t)))))))))
(load "test-unitaire")
(erase-tests match)
+;;;; Tests de matching (vrai / faux)
+
;;; Symboles, chiffres, etc
(deftest (match atom divers) (match a 'a) t #'booleq)
@@ -676,7 +882,13 @@
(deftest (match ? sous-motif) (match (a (1 $ ? 2)? c) '(a (1 b 2) c)) t #'booleq)
(deftest (match ? sous-motif) (match (a (1 $ ? 2)? c) '(a c)) t #'booleq)
-;; (? tests...)
+;;; (? tests...)
+
+;; TODO : not, nand et nor + notation infixe (ou peut-être pas).
+
+;; Identity par défaut.
+(deftest (match predicats zéro) (match (?) t) t #'booleq)
+(deftest (match predicats zéro) (match (?) nil) nil #'booleq)
(deftest (match predicats un) (match (? numberp) 1) t #'booleq)
(deftest (match predicats un) (match (? numberp) 'a) nil #'booleq)
@@ -706,4 +918,196 @@
(deftest (match predicats lambda) (match (? numberp (lambda (y) (> y 3))) 5) t #'booleq)
(deftest (match predicats lambda) (match (? numberp (lambda (y) (> y 3))) 3) nil #'booleq)
+;; Tests de preprocess-capture
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x . nil))
+ '(x nil nil nil nil))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x . a))
+ '(x nil a nil nil))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x . (a)))
+ '(nil nil (x nil a nil nil) nil (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x a))
+ '(nil nil (x nil a nil nil) nil (nil nil nil nil nil)))
+
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x a *))
+ '(nil nil (x nil a nil nil) * (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (a *))
+ '(nil nil (nil nil a nil nil) * (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x (a) *))
+ '(nil nil (x nil (nil nil a nil nil) nil (nil nil nil nil nil)) * (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess nil)
+ '(nil nil nil nil nil))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess a)
+ '(nil nil a nil nil))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (a))
+ '(nil nil (nil nil a nil nil) nil (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (a * b))
+ '(nil nil (nil nil a nil nil) * (nil nil (nil nil b nil nil) nil (nil nil nil nil nil))))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess ((a)* b))
+ '(nil nil (nil nil (nil nil a nil nil) nil (nil nil nil nil nil)) * (nil nil (nil nil b nil nil) nil (nil nil nil nil nil))))
+
+;;;; Tests de capture (variables)
+
+(deftest (match append-captures)
+ (append-captures '((x . (foo bar)) (y . foo) (z . bar))
+ '(((x . nil) (y . nil) (z . nil)) (e . x)))
+ '(((x . ((foo bar))) (y . (foo)) (z . (bar))) (e . x)))
+
+(deftest (match append-captures)
+ (append-captures '((x . (1 2)) (y . 1) (z . 2))
+ '(((x . ((foo bar))) (y . (foo)) (z . (bar))) (e . x)))
+ '(((x . ((1 2) (foo bar))) (y . (1 foo)) (z . (2 bar))) (e . x)))
+
+(deftest (match make-empty-matches)
+ (make-empty-matches (pattern-match-preprocess (:y _ :z _)))
+ '((y . nil) (z . nil)))
+
+(deftest (match make-empty-matches)
+ (make-empty-matches (pattern-match-preprocess ((:y _)* :z _)))
+ '((y . nil) (z . nil)))
+
+(deftest (match capture misc)
+ (match (:x ((:y _)* :z _)*) '(((foo) (bar) baz) ((1) 2) ((a) (b) (c) d)))
+ '((x . (((foo) (bar) baz) ((1) 2) ((a) (b) (c) d)))
+ (y . ((foo bar) (1) (a b c)))
+ (z . (baz 2 d))))
+
+(deftest (match capture misc)
+ (match (:x ((:y _)* :z _)*) '(((foo) (bar) baz) (2) ((a) (b) (c) d)))
+ '((x . (((foo) (bar) baz) (2) ((a) (b) (c) d)))
+ (y . ((foo bar) () (a b c)))
+ (z . (baz 2 d))))
+
+(deftest (match capture misc)
+ (match (:x ((:y _)* :z _)*) '())
+ '((x . ())
+ (y . ())
+ (z . ())))
+
+(deftest (match capture keyword-for-single-pattern) (match (:x . _) '(foo bar baz) x) '(foo bar baz))
+(deftest (match capture keyword-for-single-pattern) (match :x _ '(foo bar baz) x) '(foo bar baz))
+
+(deftest (match capture litteral-keyword) (match :x :x 'foo x) nil)
+(deftest (match capture litteral-keyword) (match :x :x :x x) :x)
+(deftest (match capture litteral-keyword) (match (:x :x) '(foo) x) nil)
+(deftest (match capture litteral-keyword) (match (:x :x) '(:x) x) :x)
+
+(deftest (match capture last-cons) (match (foo :x . _) '(foo bar baz) x) '(bar baz))
+(deftest (match capture last-cons) (match (:x . _) '(foo bar baz) x) '(foo bar baz))
+
+(deftest (match capture simple) (match :x $ 'foo x) 'foo)
+(deftest (match capture simple) (match :x @ 'foo x) nil)
+
+(deftest (match capture simple)
+ (match (:x _)
+ '(foo)
+ x)
+ 'foo)
+
+(deftest (match capture multi ext 1)
+ (match (:x _ *)
+ '(foo bar baz)
+ x)
+ '(foo bar baz))
+
+(deftest (match capture multi int 1)
+ (match ((:x _) *)
+ '((foo) (bar) (baz))
+ x)
+ '(foo bar baz))
+
+(deftest (match capture multi ext 2)
+ (match ((:x _ *) *)
+ '((foo bar baz) ;; expr de ext 1
+ ()
+ (quux))
+ x)
+ '((foo bar baz) ;; résultat de ext 1
+ ()
+ (quux)))
+
+(deftest (match capture multi int 2)
+ (match (((:x _) *) *)
+ '(((foo) (bar) (baz)) ;; expr de int 1
+ ()
+ ((quux)))
+ x)
+ '((foo bar baz) ;; résultat de int 1
+ ()
+ (quux)))
+
+(deftest (match capture multi ext 3)
+ (match (((:x _ *) *) *)
+ '(((foo bar baz) () (quux)) ;; expr de ext 2
+ ()
+ ((1 2) (3)))
+ x)
+ '(((foo bar baz) () (quux)) ;; résultat de ext 2
+ ()
+ ((1 2) (3))))
+
+(deftest (match capture multi int 3)
+ (match ((((:x _) *) *) *)
+ '((((foo) (bar) (baz)) () ((quux))) ;; expr de int 2
+ ()
+ (((1) (2)) ((3))))
+ x)
+ '(((foo bar baz) () (quux)) ;; résultat de int 2
+ ()
+ ((1 2) (3))))
+
+(deftest (match capture labels)
+ (match (labels :declarations ((:name $ :params (:param $*) :fbody _*) *) :body _*)
+ '(labels ((foo (x y) (list x y))
+ (bar (z w) (print z) (print w))
+ (quux ()))
+ (foo 1 2)
+ (bar 3 4))
+ param)
+ '((x y) (z w) ()))
+
+;; Extrait une liste associative nom . lambda correspondant aux déclarations,
+;; en rajoutant labels- devant chaque nom de paramètre (juste pour le fun).
+(deftest (match capture labels)
+ (match (labels :declarations ((:name $ :params (:param $*) :fbody _*) *) :body _*)
+ '(labels ((foo (x y) (list x y))
+ (bar (z w) (print z) (print w))
+ (quux ()))
+ (foo 1 2)
+ (bar 3 4))
+ (mapcar (lambda (name params fbody)
+ `(,name (lambda ,(mapcar (lambda (param)
+ (intern (format nil "LABELS-~w" param)))
+ params)
+ ,@fbody)))
+ declarations))
+ '((foo . (lambda (labels-x labels-y) (list x y)))
+ (bar . (lambda (labels-z labels-w) (print z) (print w)))
+ (quux . (lambda ()))))
+
+
+
;(run-tests match)
