From 26bd8b4fb9175dd554a634c16bc3f7b1eb4e30c2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <jahvascriptmaniac+github@free.fr>
Date: Sat, 6 Nov 2010 23:42:43 +0100
Subject: [PATCH] Import de ma version de match

---
 match.lisp | 638 +++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 521 insertions(+), 117 deletions(-)

diff --git a/match.lisp b/match.lisp
index 9ec8286..83bedcf 100644
--- 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))))
+(defun keyword-to-symbol (keyword)
+  (intern (format nil "~a" keyword)))
 
-(defmacro match (pattern expr)
-  `(pattern-match
-    (pattern-match-preprocess
-     (pattern-match-do-lambdas ,pattern))
-    ,expr))
+(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)