Import de ma version de match
This commit is contained in:
Georges Dupéron
parent
017f4e0d02
commit
26bd8b4fb9
638
match.lisp
638
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user