match.lisp (85990B)
1 (require 'util "util") ;; n-consp 2 3 ;; Syntaxe : (match <motif> expression) 4 ;; ex: (match (:a ? :c) '(a b c)) => t 5 ;; Motif Condition 6 ;; (pattern * . rest) ;; matche 0 à n occurences de pattern. 7 ;; ;; Attention, la complexité est 2^n dans le pire des cas. 8 ;; (pattern + . rest) ;; idem, mais au moins 1 occurence 9 ;; (pattern ? . rest) ;; idem, 0 ou une occurences 10 ;; (? and p1 ... pn) (every (lambda (x) (funcall x expr)) '(p1 ... pn)) 11 ;; (? or p1 ... pn) (some (lambda (x) (funcall x expr)) '(p1 ... pn)) 12 ;; (? <code>) (funcall (lambda (x) <code>) expr) 13 ;; ;; Note : fonctionne aussi pour and et or. 14 ;; (? (lambda ...)) (funcall (lambda ...) expr) 15 ;; (? symbole) (funcall 'symbole expr) ;; en général, #'symbole est un prédicat. 16 ;; (a . rest) (and (match a (car expr)) (match rest (cdr expr))) 17 ;; () (null expr) 18 ;; $ (and (atom expr) (not (null expr))) 19 ;; $$ (symbolp expr) 20 ;; $k (keywordp expr) 21 ;; $n (numberp expr) 22 ;; $ap (assembly-place-p expr) ;; définie dans compilation.lisp 23 ;; $iap (immutable-assembly-place-p expr) ;; définie dans compilation.lisp 24 ;; $map (mutable-assembly-place-p expr) ;; définie dans compilation.lisp 25 ;; $& (and (symbolp expr) (member expr '(&optional &rest &key &allow-other-keys &aux))) 26 ;; @ liste propre : (and (listp expr) (match @ (cdr expr))) 27 ;; @. cons : (consp expr) 28 ;; _ t 29 ;; :symbole Nom pour la capture (voir le paragraphe ci-dessous) 30 ;; symbole (eq 'symbole expr) 31 ;; Autres valeurs (equal <valeur> epxr) 32 ;; 33 ;; TODO : faire en sorte que si pattern est une chaîne, alors c'est une 34 ;; regexp qu'on matche avec l'expression correspondante. 35 ;; 36 ;; De plus, si :symbole précède un pattern "simple" (pas de * + ?), 37 ;; si le motif correspond à l'expression, plutôt que de renvoyer T, 38 ;; match renverra une liste associative où :sybole est associé à la 39 ;; portion de l'expression qui correspond au motif suivant :symbole. 40 ;; Dans le cas où le pattern n'est pas "simple", la valeur correspondante 41 ;; sera une liste de toutes les occurences de pattern 42 43 (declaim (ftype function assembly-place-p)) ;; définie dans compilation.lisp 44 (declaim (ftype function immutable-assembly-place-p)) ;; définie dans compilation.lisp 45 (declaim (ftype function mutable-assembly-place-p)) ;; définie dans compilation.lisp 46 47 (defun pattern-match-do-lambdas-transform (pattern) 48 (mapcar (lambda (pred) 49 (cond ((atom pred) (list 'function pred)) 50 ((eq (car pred) 'function) pred) 51 ((eq (car pred) 'lambda) pred) 52 (t 53 `(lambda (x) x ,pred)))) 54 pattern)) 55 56 (defun pattern-match-do-lambdas-1 (pattern) 57 (if (atom pattern) 58 `',pattern 59 `(list ',(first pattern) 60 ',(second pattern) 61 ,(if (second pattern) 62 (let ((?-clause (cdr (third pattern))) 63 (type '_)) 64 (when (and (consp ?-clause) (member (car ?-clause) '(nil _ $ $$ $k $n $ap $iap $map $& @ @.))) 65 (setq type (car ?-clause)) 66 (setq ?-clause (cdr ?-clause))) 67 ;; TODO : (? or foo (? _ and bar baz) (? $ and quux)) 68 (cond ((atom ?-clause) `(list ',type 'and #'identity)) 69 ((eq 'and (first ?-clause)) `(list ',type 'and ,@(pattern-match-do-lambdas-transform (cdr ?-clause)))) 70 ((eq 'or (first ?-clause)) `(list ',type 'or ,@(pattern-match-do-lambdas-transform (cdr ?-clause)))) 71 (t `(list ',type 'and ,@(pattern-match-do-lambdas-transform ?-clause))))) 72 (pattern-match-do-lambdas-1 (third pattern))) 73 ',(fourth pattern) 74 ,(pattern-match-do-lambdas-1 (fifth pattern))))) 75 76 (defmacro pattern-match-do-lambdas (pattern) 77 "Transforme les (? (<code>)) et (? (lambda ...)) en vrais lambdas." 78 (pattern-match-do-lambdas-1 pattern)) 79 80 (defun transform-symbol-to-multi (pat) 81 (let ((str-sym (string pat))) 82 (if (< (length str-sym) 2) 83 pat 84 (let* ((sym (map 'list #'identity str-sym)) 85 (lsym (car (last sym)))) 86 (if (or (char= lsym #\*) 87 (char= lsym #\+) 88 (char= lsym #\?)) 89 (list (intern (format nil "~{~a~}" (butlast sym))) 90 (intern (string lsym))) 91 pat))))) 92 93 (defun pattern-match-preprocess-multi (pattern) 94 "Transforme les symbol*, symbol+ et symbol? 95 en symbol *, symbol + et symbol ?" 96 (cond ((and (consp pattern) (eq '? (first pattern))) 97 pattern) ;; On ne touche pas les (? ...) 98 ((consp pattern) 99 (labels ((transform-symbol-to-multi (pat) 100 (let ((str-sym (string pat))) 101 (if (< (length str-sym) 2) 102 pat 103 (let* ((sym (map 'list #'identity str-sym)) 104 (lsym (car (last sym)))) 105 (if (or (char= lsym #\*) 106 (char= lsym #\+) 107 (char= lsym #\?)) 108 (list (intern (format nil "~{~a~}" (butlast sym))) 109 (intern (string lsym))) 110 pat))))) 111 (recurse (pat) 112 (cond 113 ((null pat) nil) 114 ((symbolp pat) (transform-symbol-to-multi pat)) 115 ((atom pat) pat) 116 ((keywordp (car pat)) ;; TODO : non testé !!! 117 `(,(car pat) 118 ,@(recurse (cdr pat)))) 119 ((symbolp (car pat)) 120 (let ((transf (transform-symbol-to-multi (car pat)))) 121 (if (consp transf) 122 `(,@transf ,@(recurse (cdr pat))) 123 `(,transf ,@(recurse (cdr pat)))))) 124 (t (cons (pattern-match-preprocess-multi (car pat)) 125 (recurse (cdr pat))))))) 126 (recurse pattern))) 127 ((symbolp pattern) 128 (transform-symbol-to-multi pattern)) 129 (t 130 pattern))) 131 132 (defun keyword-to-symbol (keyword) 133 (intern (format nil "~a" keyword))) 134 135 (defun pattern-match-preprocess-capture (pattern &optional capture-name) 136 "Transforme pattern en un arbre (capture-name is-predicate pattern multi rest)." 137 (if (and (consp pattern) (keywordp (car pattern))) 138 ;; capture-name 139 (if (and (n-consp 2 (cdr pattern)) (member (caddr pattern) '(* + ?))) 140 ;; avec capture-name, avec multi 141 (list (keyword-to-symbol capture-name) 142 nil 143 (pattern-match-preprocess-capture (second pattern) (first pattern)) 144 (third pattern) 145 (pattern-match-preprocess-capture (cdddr pattern))) 146 ;; avec capture-name, sans multi 147 (cond 148 ;; (:x . a) 149 ((atom (cdr pattern)) 150 (list (keyword-to-symbol (car pattern)) 151 nil 152 (cdr pattern) 153 nil 154 nil)) 155 ;; (:x . (? ...)) 156 ((and (consp pattern) (eq '? (cadr pattern))) 157 (list (keyword-to-symbol (car pattern)) 158 t 159 (cdr pattern) 160 nil 161 nil)) ;; TODO 162 ;; (:x cadr-pattern . cddr-pattern) 163 (t 164 (list (keyword-to-symbol capture-name) 165 nil 166 (pattern-match-preprocess-capture (cadr pattern) (car pattern)) 167 nil 168 (pattern-match-preprocess-capture (cddr pattern)))))) 169 ;; pas de capture-name 170 (if (and (n-consp 2 pattern) (member (cadr pattern) '(* + ?))) 171 ;; sans capture-name, avec multi 172 (list (keyword-to-symbol capture-name) 173 nil 174 (pattern-match-preprocess-capture (first pattern)) 175 (second pattern) 176 (pattern-match-preprocess-capture (cddr pattern))) 177 ;; sans capture-name, sans multi 178 (cond 179 ;; a 180 ((atom pattern) 181 (list (keyword-to-symbol capture-name) 182 nil 183 pattern 184 nil 185 nil)) 186 ;; (? ...) 187 ((and (consp pattern) (eq '? (car pattern))) 188 (list (keyword-to-symbol capture-name) 189 t 190 pattern 191 nil 192 nil)) 193 ;; (car-pattern . cdr-pattern) 194 (t 195 (list (keyword-to-symbol capture-name) 196 nil 197 (pattern-match-preprocess-capture (car pattern)) 198 nil 199 (pattern-match-preprocess-capture (cdr pattern)))))))) 200 201 ;; Fonctionnement du match avec * 202 ;; 203 ;; (match (:x (:y _ :z _)* :e _) '((a b) (1 2) (foo bar) x)) 204 ;; ;; greedy match ok 205 ;; => ((:x (a b)) (:y a) (:z b)) ---> (match (:x (:y _ :z _)* :e _) '((1 2) (foo bar) x)) 206 ;; [________________________] ;; greedy match ok 207 ;; | => ((:x (1 2)) (:y 1) (:z 2)) ---> (match (:x (:y _ :z _)* :e _) '((foo bar) x)) 208 ;; | [________________________] ;; greedy match ok 209 ;; | | => ((:x (foo bar)) (:y foo) (:z bar)) ---> (match (:x (:y _ :z _)* :e _) '(x)) 210 ;; | | [________________________________] ;; not greedy match !!!! 211 ;; | | | [ car = make-empty-matches ] [cdr = matches non-greedy ] 212 ;; | +-------------+ v => (((:x nil) (:y nil) (:z nil)) (:e x)) 213 ;; | | [ --- param 1 = matches here --- ] ([ :x lst of rest of greedy ] [ matches non-greedy ]) 214 ;; | | => (append-captures ((:x (foo bar)) (:y foo) (:z bar)) (((:x nil) (:y nil) (:z nil)) (:e x))) 215 ;; | | [ ---- greedy matches appended --------] [ matches non-greedy ] 216 ;; +-------------+ | => (((:x ((foo bar))) (:y (foo)) (:z (bar))) (:e x)) 217 ;; | | [_______________________________________________] 218 ;; | v v 219 ;; | [________________________] [_______________________________________________] 220 ;; | => (append-captures ((:x (1 2)) (:y 1) (:z 2)) (((:x ((foo bar))) (:y (foo)) (:z (bar))) (:e x))) 221 ;; | => (((:x ((1 2) (foo bar))) (:y (1 foo)) (:z (2 bar))) (:e x)) 222 ;; | [_________________________________________________________] 223 ;; v v 224 ;; [________________________] [_________________________________________________________] 225 ;; => (append-captures ((:x (a b)) (:y a) (:z b)) (((:x ((1 2) (foo bar))) (:y (1 foo)) (:z (2 bar))) (:e x))) 226 ;; => (((:x ((a b) (1 2) (foo bar))) (:y (a 1 foo)) (:z (b 2 bar))) (:e x)) 227 ;; | | 228 ;; | first-multi = t | 229 ;; | => (append (car ___) (cdr ___)) | 230 ;; v v 231 ;; => ( (:x ((a b) (1 2) (foo bar))) (:y (a 1 foo)) (:z (b 2 bar)) (:e x)) 232 233 (defun append-captures-1 (captures-1 captures-2) 234 (if (endp captures-1) 235 nil 236 (if (caar captures-1) ;; ignorer les captures nommées nil 237 (cons (cons (caar captures-1) ;; nom de capture 238 (cons (cdar captures-1) ;; nouvelle capture 239 (cdr (assoc (caar captures-1) captures-2)))) 240 (append-captures-1 (cdr captures-1) captures-2)) 241 (append-captures-1 (cdr captures-1) captures-2)))) 242 243 (defun append-captures (captures-1 captures-2) 244 "captures-1 et 2 sont des alist nom-capture . arbre-capture 245 Renvoie une alist nom-capture . (append arbre-c1 arbre-c2)" 246 (cons (append-captures-1 captures-1 (car captures-2)) 247 (cdr captures-2))) 248 249 (defun make-empty-matches-1 (pattern result) 250 (if (atom pattern) 251 result 252 (let ((here (if (first pattern) ;; pas les captures nommées nil 253 (acons (first pattern) nil result) 254 result))) 255 (if (second pattern) ;; ne pas descendre dans les les (? ...) 256 here 257 (make-empty-matches-1 (fifth pattern) 258 (make-empty-matches-1 (third pattern) here)))))) 259 260 (defun make-empty-matches (pattern) 261 (reverse (make-empty-matches-1 pattern '()))) 262 263 (defun acons-capture (capture-name value captures) 264 (if (or capture-name (not captures)) 265 (acons capture-name value captures) 266 captures)) 267 268 (defun append-car-cdr-not-nil (c) 269 (if (or (car c) (cdr c)) 270 (append (car c) (cdr c)) 271 (acons nil nil nil))) 272 273 (defun append-not-nil-1 (a b) 274 (if (endp a) 275 b 276 (if (caar a) 277 (cons (car a) (append-not-nil-1 (cdr a) b)) 278 (append-not-nil-1 (cdr a) b)))) 279 280 (defun append-not-nil (a b) 281 (or (append-not-nil-1 a b) 282 (acons nil nil nil))) 283 284 (declaim (ftype function pattern-match)) ;; récursion mutuelle recursive-backtrack / pattern-match 285 (defun recursive-backtrack (pattern rest expr capture-name) 286 (or 287 ;; match greedy (on avance dans le *) 288 (and (consp expr) 289 (let ((greedy-left (pattern-match pattern (car expr)))) 290 (when greedy-left 291 (let ((greedy-right (recursive-backtrack pattern rest (cdr expr) capture-name))) 292 (when greedy-right 293 (append-captures (acons-capture capture-name (car expr) greedy-left) 294 greedy-right)))))) 295 ;; match non-greedy (on match avec le rest) 296 (let ((non-greedy (pattern-match rest expr))) 297 (when non-greedy 298 (cons (acons-capture capture-name expr (make-empty-matches pattern)) 299 non-greedy))))) 300 301 (defun pattern-match (pat expr) 302 (let ((capture-name (first pat)) 303 (is-predicate (second pat)) 304 (pattern (third pat)) 305 (multi (fourth pat)) 306 (rest (fifth pat))) 307 (if multi 308 (if (not (listp expr)) 309 nil 310 (cond 311 ;; (pattern * ...) 312 ((eq multi '*) 313 (let ((match (recursive-backtrack pattern rest expr capture-name))) 314 (when match 315 (append-car-cdr-not-nil match)))) 316 ;; (pattern + ...) 317 ((eq multi '+) 318 (let ((first-match (and (consp expr) (pattern-match pattern (car expr))))) 319 (when first-match 320 (let ((match (recursive-backtrack pattern rest (cdr expr) capture-name))) 321 (when match 322 (let ((result (append-captures first-match match))) 323 (append-car-cdr-not-nil result))))))) 324 ;; (pattern ? ...) 325 ((eq multi '?) 326 (let ((match (and (consp expr) (pattern-match pattern (car expr))))) 327 (or (when match 328 (let ((match-rest (pattern-match rest (cdr expr)))) 329 (when match-rest 330 ;; Attention, les trois lignes suivantes ont été modifiées sans que je comprenne vraiement les manipulations... 331 (append-car-cdr-not-nil 332 (append-captures match (cons (acons-capture capture-name expr (make-empty-matches pattern)) 333 match-rest)))))) 334 (let ((match-only-rest (pattern-match rest expr))) 335 (when match-only-rest 336 (append (acons-capture capture-name expr (make-empty-matches pattern)) 337 match-only-rest)))))))) 338 (if rest 339 ;; (pattern . rest) 340 (and (consp expr) 341 (let ((left (pattern-match pattern (car expr)))) 342 (when left 343 (let ((right (pattern-match rest (cdr expr)))) 344 (when right 345 (acons-capture capture-name expr (append-not-nil left right))))))) 346 ;; pattern est un atom 347 (cond 348 ;; (? <prédicat(s)>) 349 (is-predicate 350 (when (and (pattern-match `(nil nil ,(car pattern) nil nil) expr) 351 (cond 352 ;; (? _ and symbole-1 ... symbole-n) 353 ((eq 'and (second pattern)) 354 (every (lambda (predicat) (funcall predicat expr)) (cddr pattern))) 355 ;; (? _ or symbole-1 ... symbole-n) 356 ((eq 'or (second pattern)) 357 (some (lambda (predicat) (funcall predicat expr)) (cddr pattern))))) 358 (acons-capture capture-name expr nil))) 359 ;; () 360 ((null pattern) 361 (when (null expr) 362 (acons-capture capture-name expr nil))) 363 ;; $ 364 ((eq '$ pattern) 365 (when (and (atom expr) 366 (not (null expr))) 367 (acons-capture capture-name expr nil))) 368 ;; $$ 369 ((eq '$$ pattern) 370 (when (symbolp expr) 371 (acons-capture capture-name expr nil))) 372 ;; $k 373 ((eq '$k pattern) 374 (when (keywordp expr) 375 (acons-capture capture-name expr nil))) 376 ;; $ap 377 ((eq '$ap pattern) 378 (when (assembly-place-p expr) 379 (acons-capture capture-name expr nil))) 380 ;; $iap 381 ((eq '$iap pattern) 382 (when (immutable-assembly-place-p expr) 383 (acons-capture capture-name expr nil))) 384 ;; $ap 385 ((eq '$map pattern) 386 (when (mutable-assembly-place-p expr) 387 (acons-capture capture-name expr nil))) 388 ;; $n 389 ((eq '$n pattern) 390 (when (numberp expr) 391 (acons-capture capture-name expr nil))) 392 ;; $& 393 ((eq '$& pattern) 394 (when (and (symbolp expr) (member expr '(&optional &rest &key &allow-other-keys &aux))) 395 (acons-capture capture-name expr nil))) 396 ;; @ 397 ((eq '@ pattern) 398 (when (propper-list-p expr) 399 (acons-capture capture-name expr nil))) 400 ;; @. 401 ((eq '@. pattern) 402 (when (consp expr) 403 (acons-capture capture-name expr nil))) 404 ;; _ 405 ((eq '_ pattern) 406 (acons-capture capture-name expr nil)) 407 ;; Autres valeurs (symbole, nombre, etc.) 408 (t 409 (when (equal pattern expr) 410 (acons-capture capture-name expr nil)))))))) 411 412 (defmacro pattern-match-preprocess (pattern) 413 "Tous les preprocess de pattern-match en un seul appel." 414 `(pattern-match-do-lambdas 415 ,(pattern-match-preprocess-capture 416 (pattern-match-preprocess-multi 417 pattern)))) 418 419 (defmacro real-match (pattern expr body &optional else-clause) 420 (let* ((result-sym (make-symbol "RESULT")) 421 (result-of-if-sym (make-symbol "RESULT-OF-IF")) 422 (pattern-sym (make-symbol "PATTERN")) 423 (else-sym (make-symbol "ELSE")) 424 (pattern-preproc (pattern-match-preprocess-capture 425 (pattern-match-preprocess-multi 426 pattern))) 427 (capture-names (mapcar #'car (make-empty-matches pattern-preproc)))) 428 `(let* ((,pattern-sym (pattern-match-do-lambdas ,pattern-preproc)) 429 (,result-sym (pattern-match ,pattern-sym ,expr)) 430 (,result-of-if-sym 431 (if ,result-sym 432 ;; Si le match a été effectué avec succès 433 ,@(if body 434 ;; Si on a un body 435 ;; On bind les variables correspondant aux noms de capture 436 `((let ,(mapcar (lambda (x) `(,x (cdr (assoc ',x ,result-sym)))) 437 capture-names) 438 ;; "utilisation" des variables pour éviter les warning unused variable. 439 ,@capture-names 440 ;; On définit la fonction "else" qui produit le "code secret" permettant d'exécuter le else. 441 (labels ((else () ',else-sym)) 442 ;; On exécute le body 443 ,@body))) 444 ;; S'il n'y a pas de body, on renvoie l'alist des captures s'il y en a ou T sinon. 445 (if capture-names 446 `((remove nil ,result-sym :key #'car)) 447 `(t))) 448 ;; Si on ne match pas, on renvoie le "code secret" permettant d'exécuter le else. 449 ',else-sym))) 450 ;; Si le résultat est le "code secret" du else, on fait le else, sinon on renvoie le résultat 451 (if (eq ,result-of-if-sym ',else-sym) 452 ,else-clause 453 ,result-of-if-sym)))) 454 455 (defmacro match (pattern expr &rest body) 456 (if (keywordp pattern) 457 `(real-match (,pattern . ,expr) ,(car body) ,(cdr body)) 458 `(real-match ,pattern ,expr ,body))) 459 460 (defmacro if-match (pattern expr body-if body-else) 461 `(real-match ,pattern ,expr (,body-if) ,body-else)) 462 463 (defmacro cond-match-1 (expr cond-clauses) 464 (if (endp cond-clauses) 465 'nil 466 (if (keywordp (caar cond-clauses)) 467 `(real-match (,(caar cond-clauses) . ,(cadar cond-clauses)) 468 ,expr 469 ,(cddar cond-clauses) 470 (cond-match-1 ,expr ,(cdr cond-clauses))) 471 `(real-match ,(caar cond-clauses) 472 ,expr 473 ,(cdar cond-clauses) 474 (cond-match-1 ,expr ,(cdr cond-clauses)))))) 475 476 (defmacro cond-match (expr &rest cond-clauses) 477 (let ((expr-sym (make-symbol "expr"))) 478 `(let ((,expr-sym ,expr)) 479 (cond-match-1 ,expr-sym ,cond-clauses)))) 480 481 ;; Explication du defmatch-closures 482 ;; 483 ;; ========== État initial ========================================================== 484 ;; 485 ;; next-rule -----------> ( (lambda else) ) 486 ;; ^ 487 ;; first-car-next-rule ------| 488 ;; 489 ;; ========== Après un add-pattern-xxx ============================================== 490 ;; 491 ;; next-rule -----------> ( (lambda else) ) 492 ;; ^ 493 ;; `----------------------------------------. 494 ;; | 495 ;; old-next-rule -------> ( (lambda (x) (if pattern-1 t (funcall car-next-rule))) ) 496 ;; ^ 497 ;; first-car-next-rule ------| 498 ;; 499 ;; ========== Après un autre add-pattern-xxx ======================================== 500 ;; 501 ;; next-rule -----------> ( (lambda else) ) 502 ;; ^ 503 ;; `----------------------------------------. 504 ;; | 505 ;; old-next-rule -------> ( (lambda (x) (if pattern-2 t (funcall car-next-rule))) ) 506 ;; ^ 507 ;; `----------------------------------------. 508 ;; | 509 ;; ( (lambda (x) (if pattern-1 t (funcall car-next-rule))) ) 510 ;; ^ 511 ;; first-car-next-rule ------| 512 513 (defmacro defmatch-closures (name &rest patbody) 514 "Une première version de defmatch, techniquement intéressante, mais avec beaucoup trop de closures..." 515 (let ((add-pattern-function (intern (format nil "ADD-PATTERN-~a" name))) 516 (set-else-function (intern (format nil "SET-ELSE-~a" name)))) 517 (if patbody 518 (let ((pattern (car patbody)) 519 (body (cdr patbody)) 520 (param-expr-sym (make-symbol "param-expr")) 521 (tail-sym (make-symbol "tail"))) 522 (if (eq pattern 'else) 523 `(,set-else-function ,(if (n-consp 2 body) 524 `(lambda ,(car body) ,@(cdr body)) 525 `(lambda (x) x ,@body))) 526 (if (keywordp pattern) 527 `(defmatch-closures ,name (,pattern . ,(car body)) ,@(cdr body)) 528 `(,add-pattern-function 529 (lambda (,param-expr-sym ,tail-sym) 530 (real-match ,pattern ,param-expr-sym ,body (funcall ,tail-sym ,param-expr-sym))))))) 531 `(let* ((else-rule (list (lambda (x) x nil))) 532 (next-rule (list (list else-rule))) 533 (first-call-next-rule 534 (let ((car-next-rule (car next-rule))) 535 (lambda (x) (funcall (caar car-next-rule) x))))) 536 (defun ,name (x) 537 (funcall first-call-next-rule x)) 538 (defun ,set-else-function (else) 539 (setf (car else-rule) else)) 540 (defun ,add-pattern-function (func) 541 (let ((old-next-rule next-rule)) 542 (setq next-rule (list (list else-rule))) 543 (let ((car-next-rule (car next-rule))) 544 (setf (car (car old-next-rule)) 545 (list (lambda (x) (funcall func x (lambda (x) (funcall (caar car-next-rule) x))))))))))))) 546 547 (defmacro defmatch (name &rest patbody) 548 "Version de defmatch avec une seule closure par pattern plus deux par name." 549 (let ((add-pattern-function (intern (format nil "ADD-PATTERN-~a" name))) 550 (set-else-function (intern (format nil "SET-ELSE-~a" name)))) 551 (if patbody 552 (let ((pattern (car patbody)) 553 (body (cdr patbody)) 554 (param-expr-sym (make-symbol "param-expr"))) 555 (if (eq pattern 'else) 556 `(,set-else-function ,(if (n-consp 2 body) 557 `(lambda ,(car body) ,@(cdr body)) 558 `(lambda (x) x ,@body))) 559 (if (keywordp pattern) 560 `(defmatch ,name (,pattern . ,(car body)) ,@(cdr body)) 561 `(,add-pattern-function 562 (lambda (,param-expr-sym) 563 (real-match ,pattern 564 ,param-expr-sym 565 ((cons t ,(cons 'progn body))) 566 nil)))))) 567 `(let* ((rules nil) 568 (else-rule (lambda (x) x nil))) 569 (defun ,name (x) 570 (cdr (or (some (lambda (r) (funcall r x)) rules) 571 (cons t (funcall else-rule x))))) 572 (defun ,set-else-function (else) 573 (setf else-rule else)) 574 (defun ,add-pattern-function (func) 575 (setf rules (append rules (list func)))))))) 576 577 ;; Version de match-automaton avec loop : 578 ;; `(loop 579 ;; with ,state = ',initial-state 580 ;; with accumulator = nil 581 ;; for step = (cond-match ...) 582 ;; when (eq state 'accept) 583 ;; return (reverse accumulator) 584 ;; when (eq state 'reject) 585 ;; return nil 586 ;; do (setq state (car step))) 587 588 #| 589 Syntaxe du match-automaton : 590 (match-automaton expression initial-state 591 (stateX stateY [pattern] [code [code ...]]) 592 (stateX stateY [pattern] [code [code ...]]) 593 ...) 594 - certains noms d'état pour stateX et stateY sont réservés : initial accept reject do collect 595 596 (stateX stateY) 597 - Si pattern n'est pas fourni, alors stateY est en général accept ou reject, pour indiquer qu'on accepte ou rejette l'expression si on arrive sur cet état à la fin. 598 - stateY peut aussi être un autre état, auquel cas, si tous les pattern de stateX échouent, ou si on se retrouve à la fin (de la liste qu'on analyse), 599 on jump vers stateY au lieu d'aller à reject (note : il est possible de faire une boucle infinie ainsi). 600 601 (stateX stateY pattern) 602 - Si pattern est fourni, cela signifie «Si l'élément courant de l'expression matche avec ce pattern, passer à l'élément suivant et aller dans l'état stateY.». 603 - Lorsque l'expression est acceptée, pattern-match renvoie une liste associative ((state1 élément-1 ... élément-n) (state2 e1..eN) ...) 604 - Les éléments à droite de chaque nom d'état sont obtenus de la manière suivante : 605 - Si code est fourni: (stateX stateY pattern code*) 606 il est exécuté, et sa valeur de retour est ajoutée à la fin de la liste correspondant à stateX (l'état de départ). 607 - Si code n'est pas fourni : (stateX stateY pattern) 608 rien n'est ajouté à cette liste. 609 - Lorsqu'on est sur un certain état, chaque transition partant de cet état est testée dans l'ordre d'écriture, et la première qui matche est choisie. 610 611 De plus, il est possible de spécifier des clauses spéciales, au lieu des (stateX stateY [pattern] [code]) : 612 - (initial code ...) qui exécute le code avant de démarrer (pas très utile…) 613 614 - (accept code ...) qui exécute le code dans le cas où l'expression est acceptée. La valeur renvoyée par ce code sera la valeur de retour de match-automaton. 615 Dans cette clause, on peut accéder à la valeur qui aurait dû être renvoyée via la variable return-value. 616 617 - (reject code ...) qui exécute le code dans le cas où l'expression est rejetée. La valeur renvoyée par ce code sera la valeur de retour de match-automaton. 618 Dans cette clause, le dernier élément considéré est stocké dans last-element. 619 Cet élément est celui qui a causé le reject, ou nil si on est au début de la liste, ou nil si on est à la fin de la liste sans accept. 620 De même, le dernier état courant est dans last-state. 621 622 - (stateX do code ...) qui exécute code à chaque fois qu'on entre sur stateX. 623 On peut accéder à last-element et last-state. 624 625 - (stateX collect code ...) qui exécute code à chaque fois qu'on entre sur stateX et ajoute sa valeur de retour à la fin de la liste correspondant à stateX. 626 On peut accéder à last-element et last-state. 627 628 Il peut y avoir plusieurs initial, accept et reject, auquel cas tous sont exécutés dans l'ordre d'écriture, et sont concaténés dans un progn, 629 donc seule la valeur de la dernière expression de la dernière clause est renvoyée. 630 |# 631 632 ;; ATTENTION, par excès de flemme, match-automaton ne supporte pas la syntaxe 633 ;; de découplage du nom de capture et de l'élément : (macro :var atom expr code) 634 ;; ATTENTION, j'ai renoncé à rendre ce code lisible. 635 (defun match--transitions-to-progns (transitions) 636 ;; On remet to, pattern et code bout à bout (c'est tout du code) 637 (mapcar (lambda (x) `(progn ,(car x) ,@(cadr x) ,@(caddr x))) 638 transitions)) 639 640 (defmacro match-automaton (expr initial-state &rest rules) 641 (match ((:from $$ :to _ :pattern _? :code _*) *) rules 642 (let ((storage (mapcar (lambda (s) (cons s (make-symbol (format nil "STORAGE-~a" (string s))))) (remove-duplicates from))) 643 (expr-sym (make-symbol "EXPR")) 644 (block-sym (make-symbol "BLOCK")) 645 (grouped-transitions (group (mapcar #'list from to pattern code))) 646 (last-state-sym (make-symbol "LAST-STATE")) 647 (last-element-sym (make-symbol "LAST-ELEMENT"))) 648 `(let (,@(mapcar (lambda (s) `(,(cdr s) nil)) storage) 649 (,expr-sym ,expr) 650 (,last-state-sym 'initial) 651 (,last-element-sym nil)) 652 (block ,block-sym 653 (tagbody 654 initial 655 (progn ,(match--transitions-to-progns (cdr (assoc 'initial grouped-transitions)))) 656 (go ,initial-state) 657 accept 658 (let ((return-value (list ,@(mapcar (lambda (s) `(cons ',(car s) (reverse ,(cdr s)))) storage)))) 659 return-value 660 (return-from ,block-sym 661 (progn return-value 662 ,@(match--transitions-to-progns (cdr (assoc 'accept grouped-transitions)))))) 663 reject 664 (return-from ,block-sym 665 (let ((last-element ,last-element-sym) 666 (last-state ,last-state-sym)) 667 last-element 668 last-state 669 (progn nil 670 ,@(match--transitions-to-progns (cdr (assoc 'reject grouped-transitions)))))) 671 ;; On va générer ceci : 672 ;; state1 673 ;; (cond-match ... (go state2) ... (go state1) ...) 674 ;; state2 675 ;; (cond-match ... (go staten) ... (go reject) ...) 676 ;; staten 677 ;; (cond-match ... (go accept) ... (go state1) ...))) 678 ,@(loop 679 for (from . transitions) in grouped-transitions 680 and temp-do = nil 681 and temp-collect = nil 682 ;; syntaxe (stateX code) => exécute le code à chaque fois qu'on rentre dans stateX. 683 for jump = (member nil (reverse transitions) :key #'second) 684 unless (member from '(initial accept reject)) 685 collect from 686 and collect `(setq ,last-state-sym ',from) 687 and collect `(setq ,last-element-sym (car ,expr-sym)) 688 and if jump 689 ;; va à l'état désigné par la dernière transition "finale". 690 collect `(when (endp ,expr-sym) (go ,(caar jump))) 691 else 692 collect `(when (endp ,expr-sym) (go reject)) 693 end 694 and do (setq temp-do (remove nil (mapcar (lambda (x) (when (eq 'do (car x)) `(progn ,@(cadr x) ,@(caddr x)))) transitions))) 695 and do (setq temp-collect (remove nil (mapcar (lambda (x) (when (eq 'collect (car x)) `(progn ,@(cadr x) ,@(caddr x)))) transitions))) 696 and when (or temp-do temp-collect) 697 collect `(let ((last-element ,last-element-sym) 698 (last-state ,last-state-sym)) 699 last-element 700 last-state 701 ,@(if temp-do `((progn ,@temp-do)) nil) 702 ,@(if temp-collect `((push (progn ,@temp-collect) ,(cdr (assoc from storage)))) nil)) 703 end 704 and collect `(cond-match (car ,expr-sym) 705 ,@(loop 706 for (to pattern code) in transitions 707 unless (or (not pattern) (eq to 'do) (eq to 'collect)) 708 if code 709 collect `(,@pattern 710 (push (progn ,@code) ,(cdr (assoc from storage))) 711 (setq ,expr-sym (cdr ,expr-sym)) 712 (go ,to)) 713 else 714 collect `(,@pattern 715 (setq ,expr-sym (cdr ,expr-sym)) 716 (go ,to))) 717 (_ ,(if jump `(go ,(caar jump)) '(go reject))))))))))) 718 719 (require 'test-unitaire "test-unitaire") 720 (erase-tests match) 721 722 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 0%")) 723 724 ;;;; Tests de matching (vrai / faux) 725 726 ;;; Symboles, chiffres, etc 727 728 (deftest (match atom divers) (match a 'a) t #'booleq) 729 (deftest (match atom divers) (match 1 '1) t #'booleq) 730 (deftest (match atom divers) (match 1 '1.0) nil #'booleq) ;; TODO : devrait être nil ou t ? 731 (deftest (match atom divers) (match a 'b) nil #'booleq) ;; $ oui, a non 732 (deftest (match atom divers) (match 1 '2) nil #'booleq) ;; $ oui, 1 non 733 (deftest (match atom divers) (match a '()) nil #'booleq) 734 (deftest (match atom divers) (match a '(a)) nil #'booleq) 735 (deftest (match atom divers) (match a '(a b)) nil #'booleq) 736 (deftest (match atom divers) (match a '(a . b)) nil #'booleq) 737 738 ;; Même chose que pour symboles, mais avec $ 739 740 (deftest (match atom $) (match $ 'a) t #'booleq) 741 (deftest (match atom $) (match $ '1) t #'booleq) 742 (deftest (match atom $) (match $ '1.0) t #'booleq) ;; $ oui, 1 je sais pas 743 (deftest (match atom $) (match $ 'b) t #'booleq) ;; $ oui, a non 744 (deftest (match atom $) (match $ '2) t #'booleq) ;; $ oui, 1 non 745 (deftest (match atom $) (match $ '()) nil #'booleq) 746 (deftest (match atom $) (match $ '(a)) nil #'booleq) 747 (deftest (match atom $) (match $ '(a b)) nil #'booleq) 748 (deftest (match atom $) (match $ '(a . b)) nil #'booleq) 749 750 ;;; Listes et sous-lites 751 (deftest (match listes) (match () '()) t #'booleq) 752 (deftest (match listes) (match () '(a)) nil #'booleq) 753 (deftest (match listes) (match () 'a) nil #'booleq) 754 (deftest (match listes) (match () '(a . b)) nil #'booleq) 755 756 (deftest (match listes) (match (a) '(a)) t #'booleq) 757 (deftest (match listes) (match (a) '(b)) nil #'booleq) 758 (deftest (match listes) (match (a) 'a) nil #'booleq) 759 (deftest (match listes) (match (a) '(a b)) nil #'booleq) 760 (deftest (match listes) (match (a) '()) nil #'booleq) 761 762 (deftest (match listes) (match (a b) '(a b)) t #'booleq) 763 (deftest (match listes) (match (a b) '(a c)) nil #'booleq) 764 (deftest (match listes) (match (a b) '(c b)) nil #'booleq) 765 (deftest (match listes) (match (a b) '(a)) nil #'booleq) 766 (deftest (match listes) (match (a b) '()) nil #'booleq) 767 (deftest (match listes) (match (a b) 'a) nil #'booleq) 768 (deftest (match listes) (match (a b) '(a b c)) nil #'booleq) 769 770 (deftest (match listes) (match (a (1 2 3) c) '(a (1 2 3) c)) t #'booleq) 771 (deftest (match listes) (match (a (1 2 3) c) '(a (1 2) c)) nil #'booleq) 772 (deftest (match listes) (match (a (1 2 3) c) '(a () c)) nil #'booleq) 773 (deftest (match listes) (match (a (1 2 3) c) '(x (1 2 3) c)) nil #'booleq) 774 775 ;;; _ 776 777 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 5%")) 778 779 (deftest (match _) (match _ 'a) t #'booleq) 780 (deftest (match _) (match _ '(a b)) t #'booleq) 781 (deftest (match _) (match _ '()) t #'booleq) 782 783 (deftest (match _ fin-de-liste) (match (a _) '(a b)) t #'booleq) 784 (deftest (match _ fin-de-liste) (match (a _) '(a (1 2 3))) t #'booleq) 785 (deftest (match _ fin-de-liste) (match (a _) '(a (b c))) t #'booleq) 786 (deftest (match _ fin-de-liste) (match (a _) '(a (b))) t #'booleq) 787 (deftest (match _ fin-de-liste) (match (a _) '(a ())) t #'booleq) 788 (deftest (match _ fin-de-liste) (match (a _) '(a (b . c))) t #'booleq) 789 (deftest (match _ fin-de-liste) (match (a _) '(x b)) nil #'booleq) 790 (deftest (match _ fin-de-liste) (match (a _) '(x (b))) nil #'booleq) 791 (deftest (match _ fin-de-liste) (match (a _) '(a)) nil #'booleq) 792 (deftest (match _ fin-de-liste) (match (a _) '(a b c)) nil #'booleq) 793 (deftest (match _ fin-de-liste) (match (a _) '()) nil #'booleq) 794 (deftest (match _ fin-de-liste) (match (a _) 'a) nil #'booleq) 795 796 (deftest (match _ milieu-de-liste) (match (a _ c) '(a b c)) t #'booleq) 797 (deftest (match _ milieu-de-liste) (match (a _ c) '(a (1 2 3) c)) t #'booleq) 798 (deftest (match _ milieu-de-liste) (match (a _ c) '(a (b c) c)) t #'booleq) 799 (deftest (match _ milieu-de-liste) (match (a _ c) '(a (b) c)) t #'booleq) 800 (deftest (match _ milieu-de-liste) (match (a _ c) '(a () c)) t #'booleq) 801 (deftest (match _ milieu-de-liste) (match (a _ c) '(a (b . c) c)) t #'booleq) 802 (deftest (match _ milieu-de-liste) (match (a _ c) '(x (b) c)) nil #'booleq) 803 (deftest (match _ milieu-de-liste) (match (a _ c) '(x b c)) nil #'booleq) 804 (deftest (match _ milieu-de-liste) (match (a _ c) '(x (b) c)) nil #'booleq) 805 (deftest (match _ milieu-de-liste) (match (a _ c) '(a c)) nil #'booleq) 806 (deftest (match _ milieu-de-liste) (match (a _ c) '(a)) nil #'booleq) 807 (deftest (match _ milieu-de-liste) (match (a _ c) '(a b c d)) nil #'booleq) 808 (deftest (match _ milieu-de-liste) (match (a _ c) '()) nil #'booleq) 809 (deftest (match _ milieu-de-liste) (match (a _ c) 'a) nil #'booleq) 810 (deftest (match _ milieu-de-liste) (match (a _ c) '(a b b c)) nil #'booleq) 811 (deftest (match _ milieu-de-liste) (match (a _ c) '(a b x c)) nil #'booleq) 812 813 (deftest (match _ fin-de-cons) (match (a . _) '(a b)) t #'booleq) 814 (deftest (match _ fin-de-cons) (match (a . _) '(a b c)) t #'booleq) 815 (deftest (match _ fin-de-cons) (match (a . _) '(a)) t #'booleq) 816 (deftest (match _ fin-de-cons) (match (a . _) '(a b . c)) t #'booleq) 817 (deftest (match _ fin-de-cons) (match (a . _) '(a . b)) t #'booleq) 818 (deftest (match _ fin-de-cons) (match (a . _) '(a . (b c))) t #'booleq) ;; equivalent à '(a b c) 819 (deftest (match _ fin-de-cons) (match (a . _) '(a . ())) t #'booleq) ;; equivalent à '(a) 820 (deftest (match _ fin-de-cons) (match (a . _) '(x . b)) nil #'booleq) 821 (deftest (match _ fin-de-cons) (match (a . _) '(x b c)) nil #'booleq) 822 (deftest (match _ fin-de-cons) (match (a . _) '(x)) nil #'booleq) 823 (deftest (match _ fin-de-cons) (match (a . _) '()) nil #'booleq) 824 (deftest (match _ fin-de-cons) (match (a . _) 'a) nil #'booleq) 825 826 (deftest (match _ cons) (match (a _ . _) '(a b . c)) t #'booleq) 827 (deftest (match _ cons) (match (a _ . _) '(a () . ())) t #'booleq) 828 (deftest (match _ cons) (match (a _ . _) '(a (1) . (2))) t #'booleq) 829 (deftest (match _ cons) (match (a _ . _) '(a 1 . (2))) t #'booleq) ;; equivalent à '(a 1 2) 830 (deftest (match _ cons) (match (a _ . _) '(a (1) . 2)) t #'booleq) 831 (deftest (match _ cons) (match (a _ . _) '(a)) nil #'booleq) 832 (deftest (match _ cons) (match (a _ . _) 'a) nil #'booleq) 833 834 (deftest (match _ liste) (match (_) '(a)) t #'booleq) 835 (deftest (match _ liste) (match (_) '(())) t #'booleq) 836 (deftest (match _ liste) (match (_) '((a b))) t #'booleq) 837 (deftest (match _ liste) (match (_) '(a b)) nil #'booleq) 838 (deftest (match _ liste) (match (_) '()) nil #'booleq) 839 (deftest (match _ liste) (match (_) 'a) nil #'booleq) 840 841 ;;; @ Mêmes tests que _ , on indique les différences avec ";; diff" à la fin de la ligne. 842 843 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 10%")) 844 845 (deftest (match @) (match @ 'a) nil #'booleq) ;; diff 846 (deftest (match @) (match @ '(a b)) t #'booleq) 847 (deftest (match @) (match @ '()) t #'booleq) 848 849 (deftest (match @ fin-de-liste) (match (a @) '(a b)) nil #'booleq) ;; diff 850 (deftest (match @ fin-de-liste) (match (a @) '(a (1 2 3))) t #'booleq) 851 (deftest (match @ fin-de-liste) (match (a @) '(a (b c))) t #'booleq) 852 (deftest (match @ fin-de-liste) (match (a @) '(a (b))) t #'booleq) 853 (deftest (match @ fin-de-liste) (match (a @) '(a ())) t #'booleq) 854 (deftest (match @ fin-de-liste) (match (a @) '(a (b . c))) nil #'booleq) ;; diff 855 (deftest (match @ fin-de-liste) (match (a @) '(x b)) nil #'booleq) 856 (deftest (match @ fin-de-liste) (match (a @) '(x (b))) nil #'booleq) 857 (deftest (match @ fin-de-liste) (match (a @) '(a)) nil #'booleq) 858 (deftest (match @ fin-de-liste) (match (a @) '(a b c)) nil #'booleq) 859 (deftest (match @ fin-de-liste) (match (a @) '()) nil #'booleq) 860 (deftest (match @ fin-de-liste) (match (a @) 'a) nil #'booleq) 861 862 (deftest (match @ milieu-de-liste) (match (a @ c) '(a b c)) nil #'booleq) ;; diff 863 (deftest (match @ milieu-de-liste) (match (a @ c) '(a (1 2 3) c)) t #'booleq) 864 (deftest (match @ milieu-de-liste) (match (a @ c) '(a (b c) c)) t #'booleq) 865 (deftest (match @ milieu-de-liste) (match (a @ c) '(a (b) c)) t #'booleq) 866 (deftest (match @ milieu-de-liste) (match (a @ c) '(a () c)) t #'booleq) 867 (deftest (match @ milieu-de-liste) (match (a @ c) '(a (b . c) c)) nil #'booleq) ;; diff 868 (deftest (match @ milieu-de-liste) (match (a @ c) '(x (b) c)) nil #'booleq) 869 (deftest (match @ milieu-de-liste) (match (a @ c) '(x b c)) nil #'booleq) 870 (deftest (match @ milieu-de-liste) (match (a @ c) '(x (b) c)) nil #'booleq) 871 (deftest (match @ milieu-de-liste) (match (a @ c) '(a c)) nil #'booleq) 872 (deftest (match @ milieu-de-liste) (match (a @ c) '(a)) nil #'booleq) 873 (deftest (match @ milieu-de-liste) (match (a @ c) '(a b c d)) nil #'booleq) 874 (deftest (match @ milieu-de-liste) (match (a @ c) '()) nil #'booleq) 875 (deftest (match @ milieu-de-liste) (match (a @ c) 'a) nil #'booleq) 876 (deftest (match @ milieu-de-liste) (match (a @ c) '(a b b c)) nil #'booleq) 877 (deftest (match @ milieu-de-liste) (match (a @ c) '(a b x c)) nil #'booleq) 878 879 (deftest (match @ fin-de-cons) (match (a . @) '(a b)) t #'booleq) 880 (deftest (match @ fin-de-cons) (match (a . @) '(a b c)) t #'booleq) 881 (deftest (match @ fin-de-cons) (match (a . @) '(a)) t #'booleq) 882 (deftest (match @ fin-de-cons) (match (a . @) '(a b . c)) nil #'booleq) ;; diff 883 (deftest (match @ fin-de-cons) (match (a . @) '(a . b)) nil #'booleq) ;; diff 884 (deftest (match @ fin-de-cons) (match (a . @) '(a . (b c))) t #'booleq) ;; equivalent à '(a b c) 885 (deftest (match @ fin-de-cons) (match (a . @) '(a . ())) t #'booleq) ;; equivalent à '(a) 886 (deftest (match @ fin-de-cons) (match (a . @) '(x . b)) nil #'booleq) 887 (deftest (match @ fin-de-cons) (match (a . @) '(x b c)) nil #'booleq) 888 (deftest (match @ fin-de-cons) (match (a . @) '(x)) nil #'booleq) 889 (deftest (match @ fin-de-cons) (match (a . @) '()) nil #'booleq) 890 (deftest (match @ fin-de-cons) (match (a . @) 'a) nil #'booleq) 891 892 (deftest (match @ cons) (match (a @ . @) '(a b . c)) nil #'booleq) ;; diff 893 (deftest (match @ cons) (match (a @ . @) '(a () . ())) t #'booleq) 894 (deftest (match @ cons) (match (a @ . @) '(a (1) . (2))) t #'booleq) 895 (deftest (match @ cons) (match (a @ . @) '(a 1 . (2))) nil #'booleq) ;; diff ;; equivalent à '(a 1 2) 896 (deftest (match @ cons) (match (a @ . @) '(a (1) . 2)) nil #'booleq) ;; diff 897 (deftest (match @ cons) (match (a @ . @) '(a)) nil #'booleq) 898 (deftest (match @ cons) (match (a @ . @) 'a) nil #'booleq) 899 900 (deftest (match @ liste) (match (@) '(a)) nil #'booleq) ;; diff 901 (deftest (match @ liste) (match (@) '(())) t #'booleq) 902 (deftest (match @ liste) (match (@) '((a b))) t #'booleq) 903 (deftest (match @ liste) (match (@) '(a b)) nil #'booleq) 904 (deftest (match @ liste) (match (@) '()) nil #'booleq) 905 (deftest (match @ liste) (match (@) 'a) nil #'booleq) 906 907 ;;; @. Mêmes tests que @ , on indique les différences avec ";; diff avec @" à la fin de la ligne. 908 909 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 20%")) 910 911 (deftest (match @.) (match @. 'a) nil #'booleq) 912 (deftest (match @.) (match @. '(a b)) t #'booleq) 913 (deftest (match @.) (match @. '()) nil #'booleq) ;; diff avec @ 914 915 (deftest (match @. fin-de-liste) (match (a @.) '(a b)) nil #'booleq) 916 (deftest (match @. fin-de-liste) (match (a @.) '(a (1 2 3))) t #'booleq) 917 (deftest (match @. fin-de-liste) (match (a @.) '(a (b c))) t #'booleq) 918 (deftest (match @. fin-de-liste) (match (a @.) '(a (b))) t #'booleq) 919 (deftest (match @. fin-de-liste) (match (a @.) '(a ())) nil #'booleq) ;; diff avec @ 920 (deftest (match @. fin-de-liste) (match (a @.) '(a (b . c))) t #'booleq) ;; diff avec @ 921 (deftest (match @. fin-de-liste) (match (a @.) '(x b)) nil #'booleq) 922 (deftest (match @. fin-de-liste) (match (a @.) '(x (b))) nil #'booleq) 923 (deftest (match @. fin-de-liste) (match (a @.) '(a)) nil #'booleq) 924 (deftest (match @. fin-de-liste) (match (a @.) '(a b c)) nil #'booleq) 925 (deftest (match @. fin-de-liste) (match (a @.) '()) nil #'booleq) 926 (deftest (match @. fin-de-liste) (match (a @.) 'a) nil #'booleq) 927 928 (deftest (match @. milieu-de-liste) (match (a @. c) '(a b c)) nil #'booleq) 929 (deftest (match @. milieu-de-liste) (match (a @. c) '(a (1 2 3) c)) t #'booleq) 930 (deftest (match @. milieu-de-liste) (match (a @. c) '(a (b c) c)) t #'booleq) 931 (deftest (match @. milieu-de-liste) (match (a @. c) '(a (b) c)) t #'booleq) 932 (deftest (match @. milieu-de-liste) (match (a @. c) '(a () c)) nil #'booleq) ;; diff avec @ 933 (deftest (match @. milieu-de-liste) (match (a @. c) '(a (b . c) c)) t #'booleq) ;; diff avec @ 934 (deftest (match @. milieu-de-liste) (match (a @. c) '(x (b) c)) nil #'booleq) 935 (deftest (match @. milieu-de-liste) (match (a @. c) '(x b c)) nil #'booleq) 936 (deftest (match @. milieu-de-liste) (match (a @. c) '(x (b) c)) nil #'booleq) 937 (deftest (match @. milieu-de-liste) (match (a @. c) '(a c)) nil #'booleq) 938 (deftest (match @. milieu-de-liste) (match (a @. c) '(a)) nil #'booleq) 939 (deftest (match @. milieu-de-liste) (match (a @. c) '(a b c d)) nil #'booleq) 940 (deftest (match @. milieu-de-liste) (match (a @. c) '()) nil #'booleq) 941 (deftest (match @. milieu-de-liste) (match (a @. c) 'a) nil #'booleq) 942 (deftest (match @. milieu-de-liste) (match (a @. c) '(a b b c)) nil #'booleq) 943 (deftest (match @. milieu-de-liste) (match (a @. c) '(a b x c)) nil #'booleq) 944 945 (deftest (match @. fin-de-cons) (match (a . @.) '(a b)) t #'booleq) 946 (deftest (match @. fin-de-cons) (match (a . @.) '(a b c)) t #'booleq) 947 (deftest (match @. fin-de-cons) (match (a . @.) '(a)) nil #'booleq) ;; diff avec @ 948 (deftest (match @. fin-de-cons) (match (a . @.) '(a b . c)) t #'booleq) ;; diff avec @ 949 (deftest (match @. fin-de-cons) (match (a . @.) '(a . b)) nil #'booleq) 950 (deftest (match @. fin-de-cons) (match (a . @.) '(a . (b c))) t #'booleq) ;; equivalent à '(a b c) 951 (deftest (match @. fin-de-cons) (match (a . @.) '(a . ())) nil #'booleq) ;; diff avec @ ;; equivalent à '(a) 952 (deftest (match @. fin-de-cons) (match (a . @.) '(x . b)) nil #'booleq) 953 (deftest (match @. fin-de-cons) (match (a . @.) '(x b c)) nil #'booleq) 954 (deftest (match @. fin-de-cons) (match (a . @.) '(x)) nil #'booleq) 955 (deftest (match @. fin-de-cons) (match (a . @.) '()) nil #'booleq) 956 (deftest (match @. fin-de-cons) (match (a . @.) 'a) nil #'booleq) 957 958 (deftest (match @. cons) (match (a @. . @.) '(a b . c)) nil #'booleq) 959 (deftest (match @. cons) (match (a @. . @.) '(a () . ())) nil #'booleq) ;; diff avec @ 960 (deftest (match @. cons) (match (a @. . @.) '(a (1) . (2))) t #'booleq) 961 (deftest (match @. cons) (match (a @. . @.) '(a 1 . (2))) nil #'booleq) 962 (deftest (match @. cons) (match (a @. . @.) '(a (1) . 2)) nil #'booleq) 963 (deftest (match @. cons) (match (a @. . @.) '(a)) nil #'booleq) 964 (deftest (match @. cons) (match (a @. . @.) 'a) nil #'booleq) 965 966 (deftest (match @. liste) (match (@.) '(a)) nil #'booleq) 967 (deftest (match @. liste) (match (@.) '(())) nil #'booleq) ;; diff avec @ 968 (deftest (match @. liste) (match (@.) '((a b))) t #'booleq) 969 (deftest (match @. liste) (match (@.) '(a b)) nil #'booleq) 970 (deftest (match @. liste) (match (@.) '()) nil #'booleq) 971 (deftest (match @. liste) (match (@.) 'a) nil #'booleq) 972 973 ;;; $ Mêmes tests que _ , on indique les différences avec ";; diff" à la fin de la ligne. 974 975 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 30%")) 976 977 (deftest (match $) (match $ 'a) t #'booleq) 978 (deftest (match $) (match $ '(a b)) nil #'booleq) ;; diff 979 (deftest (match $) (match $ '()) nil #'booleq) ;; diff 980 981 (deftest (match $ fin-de-liste) (match (a $) '(a b)) t #'booleq) 982 (deftest (match $ fin-de-liste) (match (a $) '(a (1 2 3))) nil #'booleq) ;; diff 983 (deftest (match $ fin-de-liste) (match (a $) '(a (b c))) nil #'booleq) ;; diff 984 (deftest (match $ fin-de-liste) (match (a $) '(a (b))) nil #'booleq) ;; diff 985 (deftest (match $ fin-de-liste) (match (a $) '(a ())) nil #'booleq) ;; diff 986 (deftest (match $ fin-de-liste) (match (a $) '(a (b . c))) nil #'booleq) ;; diff 987 (deftest (match $ fin-de-liste) (match (a $) '(x b)) nil #'booleq) 988 (deftest (match $ fin-de-liste) (match (a $) '(x (b))) nil #'booleq) 989 (deftest (match $ fin-de-liste) (match (a $) '(a)) nil #'booleq) 990 (deftest (match $ fin-de-liste) (match (a $) '(a b c)) nil #'booleq) 991 (deftest (match $ fin-de-liste) (match (a $) '()) nil #'booleq) 992 (deftest (match $ fin-de-liste) (match (a $) 'a) nil #'booleq) 993 994 (deftest (match $ milieu-de-liste) (match (a $ c) '(a b c)) t #'booleq) 995 (deftest (match $ milieu-de-liste) (match (a $ c) '(a (1 2 3) c)) nil #'booleq) ;; diff 996 (deftest (match $ milieu-de-liste) (match (a $ c) '(a (b c) c)) nil #'booleq) ;; diff 997 (deftest (match $ milieu-de-liste) (match (a $ c) '(a (b) c)) nil #'booleq) ;; diff 998 (deftest (match $ milieu-de-liste) (match (a $ c) '(a () c)) nil #'booleq) ;; diff 999 (deftest (match $ milieu-de-liste) (match (a $ c) '(a (b . c) c)) nil #'booleq) ;; diff 1000 (deftest (match $ milieu-de-liste) (match (a $ c) '(x (b) c)) nil #'booleq) 1001 (deftest (match $ milieu-de-liste) (match (a $ c) '(x b c)) nil #'booleq) 1002 (deftest (match $ milieu-de-liste) (match (a $ c) '(x (b) c)) nil #'booleq) 1003 (deftest (match $ milieu-de-liste) (match (a $ c) '(a c)) nil #'booleq) 1004 (deftest (match $ milieu-de-liste) (match (a $ c) '(a)) nil #'booleq) 1005 (deftest (match $ milieu-de-liste) (match (a $ c) '(a b c d)) nil #'booleq) 1006 (deftest (match $ milieu-de-liste) (match (a $ c) '()) nil #'booleq) 1007 (deftest (match $ milieu-de-liste) (match (a $ c) 'a) nil #'booleq) 1008 (deftest (match $ milieu-de-liste) (match (a $ c) '(a b b c)) nil #'booleq) 1009 (deftest (match $ milieu-de-liste) (match (a $ c) '(a b x c)) nil #'booleq) 1010 1011 (deftest (match $ fin-de-cons) (match (a . $) '(a b)) nil #'booleq) ;; diff 1012 (deftest (match $ fin-de-cons) (match (a . $) '(a b c)) nil #'booleq) ;; diff 1013 (deftest (match $ fin-de-cons) (match (a . $) '(a)) nil #'booleq) ;; diff 1014 (deftest (match $ fin-de-cons) (match (a . $) '(a b . c)) nil #'booleq) ;; diff 1015 (deftest (match $ fin-de-cons) (match (a . $) '(a . b)) t #'booleq) 1016 (deftest (match $ fin-de-cons) (match (a . $) '(a . (b c))) nil #'booleq) ;; diff ;; equivalent à '(a b c) 1017 (deftest (match $ fin-de-cons) (match (a . $) '(a . ())) nil #'booleq) ;; diff ;; equivalent à '(a) 1018 (deftest (match $ fin-de-cons) (match (a . $) '(x . b)) nil #'booleq) 1019 (deftest (match $ fin-de-cons) (match (a . $) '(x b c)) nil #'booleq) 1020 (deftest (match $ fin-de-cons) (match (a . $) '(x)) nil #'booleq) 1021 (deftest (match $ fin-de-cons) (match (a . $) '()) nil #'booleq) 1022 (deftest (match $ fin-de-cons) (match (a . $) 'a) nil #'booleq) 1023 1024 (deftest (match $ cons) (match (a $ . $) '(a b . c)) t #'booleq) 1025 (deftest (match $ cons) (match (a $ . $) '(a () . ())) nil #'booleq) ;; diff 1026 (deftest (match $ cons) (match (a $ . $) '(a (1) . (2))) nil #'booleq) ;; diff 1027 (deftest (match $ cons) (match (a $ . $) '(a 1 . (2))) nil #'booleq) ;; diff ;; equivalent à '(a 1 2) 1028 (deftest (match $ cons) (match (a $ . $) '(a (1) . 2)) nil #'booleq) ;; diff 1029 (deftest (match $ cons) (match (a $ . $) '(a)) nil #'booleq) 1030 (deftest (match $ cons) (match (a $ . $) 'a) nil #'booleq) 1031 1032 (deftest (match $ liste) (match ($) '(a)) t #'booleq) 1033 (deftest (match $ liste) (match ($) '(())) nil #'booleq) ;; diff 1034 (deftest (match $ liste) (match ($) '((a b))) nil #'booleq) ;; diff 1035 (deftest (match $ liste) (match ($) '(a b)) nil #'booleq) 1036 (deftest (match $ liste) (match ($) '()) nil #'booleq) 1037 (deftest (match $ liste) (match ($) 'a) nil #'booleq) 1038 1039 ;;; * 1040 1041 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 40%")) 1042 1043 (deftest (match * symbole) (match (a *) '(a a a a)) t #'booleq) 1044 (deftest (match * symbole) (match (a *) '(a)) t #'booleq) 1045 (deftest (match * symbole) (match (a *) '()) t #'booleq) 1046 (deftest (match * symbole) (match (a *) 'a) nil #'booleq) 1047 (deftest (match * symbole) (match (a *) '(b b b b)) nil #'booleq) 1048 (deftest (match * symbole) (match (a *) '(b)) nil #'booleq) 1049 1050 (deftest (match * _) (match (a (_ *) c) '(a ((1 2) (3) () (4 5)) c)) t #'booleq) 1051 (deftest (match * _) (match (a (_ *) c) '(a ((1 2) 3 () (4 5)) c)) t #'booleq) 1052 (deftest (match * _) (match (a (_ *) c) '(a ((1 2) (3) (4 5)) c)) t #'booleq) 1053 (deftest (match * _) (match (a (_ *) c) '(a ((1 2) (3 . x) (4 5)) c)) t #'booleq) 1054 (deftest (match * _) (match (a (_ *) c) '(a ((1 2)) c)) t #'booleq) 1055 (deftest (match * _) (match (a (_ *) c) '(a (1 2 3) c)) t #'booleq) 1056 (deftest (match * _) (match (a (_ *) c) '(a (x) c)) t #'booleq) 1057 (deftest (match * _) (match (a (_ *) c) '(a () c)) t #'booleq) 1058 (deftest (match * _) (match (a (_ *) c) '(a x c)) nil #'booleq) 1059 1060 (deftest (match * @) (match (a (@ *) c) '(a ((1 2) (3) () (4 5)) c)) t #'booleq) 1061 (deftest (match * @) (match (a (@ *) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) 1062 (deftest (match * @) (match (a (@ *) c) '(a ((1 2) (3) (4 5)) c)) t #'booleq) 1063 (deftest (match * @) (match (a (@ *) c) '(a ((1 2) (3 . x) (4 5)) c)) nil #'booleq) 1064 (deftest (match * @) (match (a (@ *) c) '(a ((1 2)) c)) t #'booleq) 1065 (deftest (match * @) (match (a (@ *) c) '(a (1 2 3) c)) nil #'booleq) 1066 (deftest (match * @) (match (a (@ *) c) '(a (x) c)) nil #'booleq) 1067 (deftest (match * @) (match (a (@ *) c) '(a () c)) t #'booleq) 1068 (deftest (match * @) (match (a (@ *) c) '(a x c)) nil #'booleq) 1069 1070 (deftest (match * @.) (match (a (@. *) c) '(a ((1 2) (3) () (4 5)) c)) nil #'booleq) 1071 (deftest (match * @.) (match (a (@. *) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) 1072 (deftest (match * @.) (match (a (@. *) c) '(a ((1 2) (3) (4 5)) c)) t #'booleq) 1073 (deftest (match * @.) (match (a (@. *) c) '(a ((1 2) (3 . x) (4 5)) c)) t #'booleq) 1074 (deftest (match * @.) (match (a (@. *) c) '(a ((1 2)) c)) t #'booleq) 1075 (deftest (match * @.) (match (a (@. *) c) '(a (1 2 3) c)) nil #'booleq) 1076 (deftest (match * @.) (match (a (@. *) c) '(a (x) c)) nil #'booleq) 1077 (deftest (match * @.) (match (a (@. *) c) '(a () c)) t #'booleq) 1078 (deftest (match * @.) (match (a (@. *) c) '(a x c)) nil #'booleq) 1079 1080 (deftest (match * $) (match (a ($ *) c) '(a ((1 2) (3) () (4 5)) c)) nil #'booleq) 1081 (deftest (match * $) (match (a ($ *) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) 1082 (deftest (match * $) (match (a ($ *) c) '(a ((1 2) (3) (4 5)) c)) nil #'booleq) 1083 (deftest (match * $) (match (a ($ *) c) '(a ((1 2) (3 . x) (4 5)) c)) nil #'booleq) 1084 (deftest (match * $) (match (a ($ *) c) '(a ((1 2)) c)) nil #'booleq) 1085 (deftest (match * $) (match (a ($ *) c) '(a (1 2 3) c)) t #'booleq) 1086 (deftest (match * $) (match (a ($ *) c) '(a (x) c)) t #'booleq) 1087 (deftest (match * $) (match (a ($ *) c) '(a () c)) t #'booleq) 1088 (deftest (match * $) (match (a ($ *) c) '(a x c)) nil #'booleq) 1089 1090 (deftest (match * dans-sous-motif) (match (a (1 $ * 2)* c) '(a (1 2) (1 b 2) (1 1 2) c)) t #'booleq) 1091 (deftest (match * dans-sous-motif) (match (a (1 $ * 2)* c) '(a (1 x 2) (1 b 2) (1 1 1 2) c)) t #'booleq) 1092 (deftest (match * dans-sous-motif) (match (a (1 $ * 2)* c) '(a (1 2) (1 b 2) (1 1 1 2) c)) t #'booleq) 1093 (deftest (match * dans-sous-motif) (match (a (1 $ * 2)* c) '(a (1 2) (1 b) (1 1 1 2) c)) nil #'booleq) 1094 (deftest (match * dans-sous-motif) (match (a (1 $ * 2)* c) '(a (1 2) 1 b 2 (1 1 1 2) c)) nil #'booleq) 1095 (deftest (match * dans-sous-motif) (match (a (1 $ * 2)* c) '(a (1 2) (1 b 2) (1 1 1 2))) nil #'booleq) 1096 1097 (deftest (match * sous-motif) (match (a (1 $ * 2)* c) '(a (1 b 2) (1 b 2) c)) t #'booleq) 1098 (deftest (match * sous-motif) (match (a (1 $ * 2)* c) '(a (1 b 2) c)) t #'booleq) 1099 (deftest (match * sous-motif) (match (a (1 $ * 2)* c) '(a c)) t #'booleq) 1100 1101 ;;; + Mêmes tests que * , on indique les différences avec ";; diff" à la fin de la ligne. 1102 1103 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 50%")) 1104 1105 (deftest (match + symbole) (match (a +) '(a a a a)) t #'booleq) 1106 (deftest (match + symbole) (match (a +) '(a)) t #'booleq) 1107 (deftest (match + symbole) (match (a +) '()) nil #'booleq) ;; diff 1108 (deftest (match + symbole) (match (a +) 'a) nil #'booleq) 1109 (deftest (match + symbole) (match (a +) '(b b b b)) nil #'booleq) 1110 (deftest (match + symbole) (match (a +) '(b)) nil #'booleq) 1111 1112 (deftest (match + _) (match (a (_ +) c) '(a ((1 2) (3) () (4 5)) c)) t #'booleq) 1113 (deftest (match + _) (match (a (_ +) c) '(a ((1 2) 3 () (4 5)) c)) t #'booleq) 1114 (deftest (match + _) (match (a (_ +) c) '(a ((1 2) (3) (4 5)) c)) t #'booleq) 1115 (deftest (match + _) (match (a (_ +) c) '(a ((1 2) (3 . x) (4 5)) c)) t #'booleq) 1116 (deftest (match + _) (match (a (_ +) c) '(a ((1 2)) c)) t #'booleq) 1117 (deftest (match + _) (match (a (_ +) c) '(a (1 2 3) c)) t #'booleq) 1118 (deftest (match + _) (match (a (_ +) c) '(a (x) c)) t #'booleq) 1119 (deftest (match + _) (match (a (_ +) c) '(a () c)) nil #'booleq) ;; diff 1120 (deftest (match + _) (match (a (_ +) c) '(a x c)) nil #'booleq) 1121 1122 (deftest (match + @) (match (a (@ +) c) '(a ((1 2) (3) () (4 5)) c)) t #'booleq) 1123 (deftest (match + @) (match (a (@ +) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) 1124 (deftest (match + @) (match (a (@ +) c) '(a ((1 2) (3) (4 5)) c)) t #'booleq) 1125 (deftest (match + @) (match (a (@ +) c) '(a ((1 2) (3 . x) (4 5)) c)) nil #'booleq) 1126 (deftest (match + @) (match (a (@ +) c) '(a ((1 2)) c)) t #'booleq) 1127 (deftest (match + @) (match (a (@ +) c) '(a (1 2 3) c)) nil #'booleq) 1128 (deftest (match + @) (match (a (@ +) c) '(a (x) c)) nil #'booleq) 1129 (deftest (match + @) (match (a (@ +) c) '(a () c)) nil #'booleq) ;; diff 1130 (deftest (match + @) (match (a (@ +) c) '(a x c)) nil #'booleq) 1131 1132 (deftest (match + @.) (match (a (@. +) c) '(a ((1 2) (3) () (4 5)) c)) nil #'booleq) 1133 (deftest (match + @.) (match (a (@. +) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) 1134 (deftest (match + @.) (match (a (@. +) c) '(a ((1 2) (3) (4 5)) c)) t #'booleq) 1135 (deftest (match + @.) (match (a (@. +) c) '(a ((1 2) (3 . x) (4 5)) c)) t #'booleq) 1136 (deftest (match + @.) (match (a (@. +) c) '(a ((1 2)) c)) t #'booleq) 1137 (deftest (match + @.) (match (a (@. +) c) '(a (1 2 3) c)) nil #'booleq) 1138 (deftest (match + @.) (match (a (@. +) c) '(a (x) c)) nil #'booleq) 1139 (deftest (match + @.) (match (a (@. +) c) '(a () c)) nil #'booleq) ;; diff 1140 (deftest (match + @.) (match (a (@. +) c) '(a x c)) nil #'booleq) 1141 1142 (deftest (match + $) (match (a ($ +) c) '(a ((1 2) (3) () (4 5)) c)) nil #'booleq) 1143 (deftest (match + $) (match (a ($ +) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) 1144 (deftest (match + $) (match (a ($ +) c) '(a ((1 2) (3) (4 5)) c)) nil #'booleq) 1145 (deftest (match + $) (match (a ($ +) c) '(a ((1 2) (3 . x) (4 5)) c)) nil #'booleq) 1146 (deftest (match + $) (match (a ($ +) c) '(a ((1 2)) c)) nil #'booleq) 1147 (deftest (match + $) (match (a ($ +) c) '(a (1 2 3) c)) t #'booleq) 1148 (deftest (match + $) (match (a ($ +) c) '(a (x) c)) t #'booleq) 1149 (deftest (match + $) (match (a ($ +) c) '(a () c)) nil #'booleq) ;; diff 1150 (deftest (match + $) (match (a ($ +) c) '(a x c)) nil #'booleq) 1151 1152 (deftest (match + dans-sous-motif) (match (a (1 $ + 2)* c) '(a (1 2) (1 b 2) (1 1 2) c)) nil #'booleq) ;; diff 1153 (deftest (match + dans-sous-motif) (match (a (1 $ + 2)* c) '(a (1 x 2) (1 b 2) (1 1 1 2) c)) t #'booleq) 1154 (deftest (match + dans-sous-motif) (match (a (1 $ + 2)* c) '(a (1 2) (1 b 2) (1 1 1 2) c)) nil #'booleq) ;; diff 1155 (deftest (match + dans-sous-motif) (match (a (1 $ + 2)* c) '(a (1 2) (1 b) (1 1 1 2) c)) nil #'booleq) 1156 (deftest (match + dans-sous-motif) (match (a (1 $ + 2)* c) '(a (1 2) 1 b 2 (1 1 1 2) c)) nil #'booleq) 1157 (deftest (match + dans-sous-motif) (match (a (1 $ + 2)* c) '(a (1 2) (1 b 2) (1 1 1 2))) nil #'booleq) 1158 1159 (deftest (match + sous-motif) (match (a (1 $ + 2)+ c) '(a (1 b 2) (1 b 2) c)) t #'booleq) 1160 (deftest (match + sous-motif) (match (a (1 $ + 2)+ c) '(a (1 b 2) c)) t #'booleq) 1161 (deftest (match + sous-motif) (match (a (1 $ + 2)+ c) '(a c)) nil #'booleq) ;; diff 1162 1163 ;;; ? Mêmes tests que * , on indique les différences avec ";; diff" à la fin de la ligne. 1164 1165 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 60%")) 1166 1167 (deftest (match ? symbole) (match (a ?) '(a a a a)) nil #'booleq) ;; diff 1168 (deftest (match ? symbole) (match (a ?) '(a)) t #'booleq) 1169 (deftest (match ? symbole) (match (a ?) '()) t #'booleq) 1170 (deftest (match ? symbole) (match (a ?) 'a) nil #'booleq) 1171 (deftest (match ? symbole) (match (a ?) '(b b b b)) nil #'booleq) 1172 (deftest (match ? symbole) (match (a ?) '(b)) nil #'booleq) 1173 1174 (deftest (match ? _) (match (a (_ ?) c) '(a ((1 2) (3) () (4 5)) c)) nil #'booleq) ;; diff 1175 (deftest (match ? _) (match (a (_ ?) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) ;; diff 1176 (deftest (match ? _) (match (a (_ ?) c) '(a ((1 2) (3) (4 5)) c)) nil #'booleq) ;; diff 1177 (deftest (match ? _) (match (a (_ ?) c) '(a ((1 2) (3 . x) (4 5)) c)) nil #'booleq) ;; diff 1178 (deftest (match ? _) (match (a (_ ?) c) '(a ((1 2)) c)) t #'booleq) 1179 (deftest (match ? _) (match (a (_ ?) c) '(a (1 2 3) c)) nil #'booleq) ;; diff 1180 (deftest (match ? _) (match (a (_ ?) c) '(a (x) c)) t #'booleq) 1181 (deftest (match ? _) (match (a (_ ?) c) '(a () c)) t #'booleq) 1182 (deftest (match ? _) (match (a (_ ?) c) '(a x c)) nil #'booleq) 1183 1184 (deftest (match ? @) (match (a (@ ?) c) '(a ((1 2) (3) () (4 5)) c)) nil #'booleq) ;; diff 1185 (deftest (match ? @) (match (a (@ ?) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) 1186 (deftest (match ? @) (match (a (@ ?) c) '(a ((1 2) (3) (4 5)) c)) nil #'booleq) ;; diff 1187 (deftest (match ? @) (match (a (@ ?) c) '(a ((1 2) (3 . x) (4 5)) c)) nil #'booleq) 1188 (deftest (match ? @) (match (a (@ ?) c) '(a ((1 2)) c)) t #'booleq) 1189 (deftest (match ? @) (match (a (@ ?) c) '(a (1 2 3) c)) nil #'booleq) 1190 (deftest (match ? @) (match (a (@ ?) c) '(a (x) c)) nil #'booleq) 1191 (deftest (match ? @) (match (a (@ ?) c) '(a () c)) t #'booleq) 1192 (deftest (match ? @) (match (a (@ ?) c) '(a x c)) nil #'booleq) 1193 1194 (deftest (match ? @.) (match (a (@. ?) c) '(a ((1 2) (3) () (4 5)) c)) nil #'booleq) 1195 (deftest (match ? @.) (match (a (@. ?) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) 1196 (deftest (match ? @.) (match (a (@. ?) c) '(a ((1 2) (3) (4 5)) c)) nil #'booleq) ;; diff 1197 (deftest (match ? @.) (match (a (@. ?) c) '(a ((1 2) (3 . x) (4 5)) c)) nil #'booleq) ;; diff 1198 (deftest (match ? @.) (match (a (@. ?) c) '(a ((1 2)) c)) t #'booleq) 1199 (deftest (match ? @.) (match (a (@. ?) c) '(a (1 2 3) c)) nil #'booleq) 1200 (deftest (match ? @.) (match (a (@. ?) c) '(a (x) c)) nil #'booleq) 1201 (deftest (match ? @.) (match (a (@. ?) c) '(a () c)) t #'booleq) 1202 (deftest (match ? @.) (match (a (@. ?) c) '(a x c)) nil #'booleq) 1203 1204 (deftest (match ? $) (match (a ($ ?) c) '(a ((1 2) (3) () (4 5)) c)) nil #'booleq) 1205 (deftest (match ? $) (match (a ($ ?) c) '(a ((1 2) 3 () (4 5)) c)) nil #'booleq) 1206 (deftest (match ? $) (match (a ($ ?) c) '(a ((1 2) (3) (4 5)) c)) nil #'booleq) 1207 (deftest (match ? $) (match (a ($ ?) c) '(a ((1 2) (3 . x) (4 5)) c)) nil #'booleq) 1208 (deftest (match ? $) (match (a ($ ?) c) '(a ((1 2)) c)) nil #'booleq) 1209 (deftest (match ? $) (match (a ($ ?) c) '(a (1 2 3) c)) nil #'booleq) ;; diff 1210 (deftest (match ? $) (match (a ($ ?) c) '(a (x) c)) t #'booleq) 1211 (deftest (match ? $) (match (a ($ ?) c) '(a () c)) t #'booleq) 1212 (deftest (match ? $) (match (a ($ ?) c) '(a x c)) nil #'booleq) 1213 1214 (deftest (match ? dans-sous-motif) (match (a (1 $ ? 2)* c) '(a (1 2) (1 b 2) (1 1 2) c)) t #'booleq) 1215 (deftest (match ? dans-sous-motif) (match (a (1 $ ? 2)* c) '(a (1 x 2) (1 b 2) (1 1 1 2) c)) nil #'booleq) ;; diff 1216 (deftest (match ? dans-sous-motif) (match (a (1 $ ? 2)* c) '(a (1 2) (1 b 2) (1 1 1 2) c)) nil #'booleq) ;; diff 1217 (deftest (match ? dans-sous-motif) (match (a (1 $ ? 2)* c) '(a (1 2) (1 b) (1 1 1 2) c)) nil #'booleq) 1218 (deftest (match ? dans-sous-motif) (match (a (1 $ ? 2)* c) '(a (1 2) 1 b 2 (1 1 1 2) c)) nil #'booleq) 1219 (deftest (match ? dans-sous-motif) (match (a (1 $ ? 2)* c) '(a (1 2) (1 b 2) (1 1 1 2))) nil #'booleq) 1220 1221 (deftest (match ? sous-motif) (match (a (1 $ ? 2)? c) '(a (1 b 2) (1 b 2) c)) nil #'booleq) ;; diff 1222 (deftest (match ? sous-motif) (match (a (1 $ ? 2)? c) '(a (1 b 2) c)) t #'booleq) 1223 (deftest (match ? sous-motif) (match (a (1 $ ? 2)? c) '(a c)) t #'booleq) 1224 1225 ;;; (? tests...) 1226 1227 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 70%")) 1228 1229 ;; TODO : not, nand et nor + notation infixe (ou peut-être pas). 1230 1231 ;; Identity par défaut. 1232 (deftest (match predicats zéro) (match (?) t) t #'booleq) 1233 (deftest (match predicats zéro) (match (?) nil) nil #'booleq) 1234 1235 (deftest (match predicats un) (match (? numberp) 1) t #'booleq) 1236 (deftest (match predicats un) (match (? numberp) 'a) nil #'booleq) 1237 1238 (deftest (match predicats un) (match (? plusp) 1) t #'booleq) 1239 (deftest (match predicats un) (match (? plusp) -1) nil #'booleq) 1240 1241 ;; and par défaut 1242 (deftest (match predicats deux and-implicite) (match (? integerp plusp) 1) t #'booleq) 1243 (deftest (match predicats deux and-implicite) (match (? integerp plusp) 0.1) nil #'booleq) 1244 (deftest (match predicats deux and-implicite) (match (? integerp plusp) -1) nil #'booleq) 1245 (deftest (match predicats deux and-implicite) (match (? integerp plusp) -0.1) nil #'booleq) 1246 1247 (deftest (match predicats deux and) (match (? and integerp plusp) 1) t #'booleq) 1248 (deftest (match predicats deux and) (match (? and integerp plusp) 0.1) nil #'booleq) 1249 (deftest (match predicats deux and) (match (? and integerp plusp) -1) nil #'booleq) 1250 (deftest (match predicats deux and) (match (? and integerp plusp) -0.1) nil #'booleq) 1251 1252 (deftest (match predicats deux or) (match (? or integerp plusp) 1) t #'booleq) 1253 (deftest (match predicats deux or) (match (? or integerp plusp) 0.1) t #'booleq) 1254 (deftest (match predicats deux or) (match (? or integerp plusp) -1) t #'booleq) 1255 (deftest (match predicats deux or) (match (? or integerp plusp) -0.1) nil #'booleq) 1256 1257 (deftest (match predicats code) (match (? numberp (> x 3)) 5) t #'booleq) 1258 (deftest (match predicats code) (match (? numberp (> x 3)) 2) nil #'booleq) 1259 1260 (deftest (match predicats lambda) (match (? numberp (lambda (y) (> y 3))) 5) t #'booleq) 1261 (deftest (match predicats lambda) (match (? numberp (lambda (y) (> y 3))) 3) nil #'booleq) 1262 1263 ;; Tests de preprocess-capture 1264 1265 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 75%")) 1266 1267 (deftest (match preprocess-capture) 1268 (pattern-match-preprocess (:x . nil)) 1269 '(x nil nil nil nil)) 1270 1271 (deftest (match preprocess-capture) 1272 (pattern-match-preprocess (:x . a)) 1273 '(x nil a nil nil)) 1274 1275 (deftest (match preprocess-capture) 1276 (pattern-match-preprocess (:x . (a))) 1277 '(nil nil (x nil a nil nil) nil (nil nil nil nil nil))) 1278 1279 (deftest (match preprocess-capture) 1280 (pattern-match-preprocess (:x a)) 1281 '(nil nil (x nil a nil nil) nil (nil nil nil nil nil))) 1282 1283 1284 (deftest (match preprocess-capture) 1285 (pattern-match-preprocess (:x a *)) 1286 '(nil nil (x nil a nil nil) * (nil nil nil nil nil))) 1287 1288 (deftest (match preprocess-capture) 1289 (pattern-match-preprocess (a *)) 1290 '(nil nil (nil nil a nil nil) * (nil nil nil nil nil))) 1291 1292 (deftest (match preprocess-capture) 1293 (pattern-match-preprocess (:x (a) *)) 1294 '(nil nil (x nil (nil nil a nil nil) nil (nil nil nil nil nil)) * (nil nil nil nil nil))) 1295 1296 (deftest (match preprocess-capture) 1297 (pattern-match-preprocess nil) 1298 '(nil nil nil nil nil)) 1299 1300 (deftest (match preprocess-capture) 1301 (pattern-match-preprocess a) 1302 '(nil nil a nil nil)) 1303 1304 (deftest (match preprocess-capture) 1305 (pattern-match-preprocess (a)) 1306 '(nil nil (nil nil a nil nil) nil (nil nil nil nil nil))) 1307 1308 (deftest (match preprocess-capture) 1309 (pattern-match-preprocess (a * b)) 1310 '(nil nil (nil nil a nil nil) * (nil nil (nil nil b nil nil) nil (nil nil nil nil nil)))) 1311 1312 (deftest (match preprocess-capture) 1313 (pattern-match-preprocess ((a)* b)) 1314 '(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)))) 1315 1316 ;;;; Tests de capture (variables) 1317 1318 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 80%")) 1319 1320 (deftest (match append-captures) 1321 (append-captures '((x . (foo bar)) (y . foo) (z . bar)) 1322 '(((x . nil) (y . nil) (z . nil)) (e . x))) 1323 '(((x . ((foo bar))) (y . (foo)) (z . (bar))) (e . x))) 1324 1325 (deftest (match append-captures) 1326 (append-captures '((x . (1 2)) (y . 1) (z . 2)) 1327 '(((x . ((foo bar))) (y . (foo)) (z . (bar))) (e . x))) 1328 '(((x . ((1 2) (foo bar))) (y . (1 foo)) (z . (2 bar))) (e . x))) 1329 1330 (deftest (match make-empty-matches) 1331 (make-empty-matches (pattern-match-preprocess (:y _ :z _))) 1332 '((y . nil) (z . nil))) 1333 1334 (deftest (match make-empty-matches) 1335 (make-empty-matches (pattern-match-preprocess ((:y _)* :z _))) 1336 '((y . nil) (z . nil))) 1337 1338 (deftest (match capture misc) 1339 (match (:x ((:y _)* :z _)*) '(((foo) (bar) baz) ((1) 2) ((a) (b) (c) d))) 1340 '((x . (((foo) (bar) baz) ((1) 2) ((a) (b) (c) d))) 1341 (y . ((foo bar) (1) (a b c))) 1342 (z . (baz 2 d)))) 1343 1344 (deftest (match capture misc) 1345 (match (:x ((:y _)* :z _)*) '(((foo) (bar) baz) (2) ((a) (b) (c) d))) 1346 '((x . (((foo) (bar) baz) (2) ((a) (b) (c) d))) 1347 (y . ((foo bar) () (a b c))) 1348 (z . (baz 2 d)))) 1349 1350 (deftest (match capture misc) 1351 (match (:x ((:y _)* :z _)*) '()) 1352 '((x . ()) 1353 (y . ()) 1354 (z . ()))) 1355 1356 (deftest (match capture keyword-for-single-pattern) (match (:x . _) '(foo bar baz) x) '(foo bar baz)) 1357 (deftest (match capture keyword-for-single-pattern) (match :x _ '(foo bar baz) x) '(foo bar baz)) 1358 1359 (deftest (match capture litteral-keyword) (match :x :x 'foo x) nil) 1360 (deftest (match capture litteral-keyword) (match :x :x :x x) :x) 1361 (deftest (match capture litteral-keyword) (match (:x :x) '(foo) x) nil) 1362 (deftest (match capture litteral-keyword) (match (:x :x) '(:x) x) :x) 1363 1364 (deftest (match capture last-cons) (match (foo :x . _) '(foo bar baz) x) '(bar baz)) 1365 (deftest (match capture last-cons) (match (:x . _) '(foo bar baz) x) '(foo bar baz)) 1366 1367 (deftest (match capture simple) (match :x $ 'foo x) 'foo) 1368 (deftest (match capture simple) (match :x @ 'foo x) nil) 1369 1370 (deftest (match capture simple) 1371 (match (:x _) 1372 '(foo) 1373 x) 1374 'foo) 1375 1376 (deftest (match capture multi ext 1) 1377 (match (:x _ *) 1378 '(foo bar baz) 1379 x) 1380 '(foo bar baz)) 1381 1382 (deftest (match capture multi int 1) 1383 (match ((:x _) *) 1384 '((foo) (bar) (baz)) 1385 x) 1386 '(foo bar baz)) 1387 1388 (deftest (match capture multi ext 2) 1389 (match ((:x _ *) *) 1390 '((foo bar baz) ;; expr de ext 1 1391 () 1392 (quux)) 1393 x) 1394 '((foo bar baz) ;; résultat de ext 1 1395 () 1396 (quux))) 1397 1398 (deftest (match capture multi int 2) 1399 (match (((:x _) *) *) 1400 '(((foo) (bar) (baz)) ;; expr de int 1 1401 () 1402 ((quux))) 1403 x) 1404 '((foo bar baz) ;; résultat de int 1 1405 () 1406 (quux))) 1407 1408 (deftest (match capture multi ext 3) 1409 (match (((:x _ *) *) *) 1410 '(((foo bar baz) () (quux)) ;; expr de ext 2 1411 () 1412 ((1 2) (3))) 1413 x) 1414 '(((foo bar baz) () (quux)) ;; résultat de ext 2 1415 () 1416 ((1 2) (3)))) 1417 1418 (deftest (match capture multi int 3) 1419 (match ((((:x _) *) *) *) 1420 '((((foo) (bar) (baz)) () ((quux))) ;; expr de int 2 1421 () 1422 (((1) (2)) ((3)))) 1423 x) 1424 '(((foo bar baz) () (quux)) ;; résultat de int 2 1425 () 1426 ((1 2) (3)))) 1427 1428 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 90%")) 1429 1430 (deftest (match capture labels) 1431 (match (labels :declarations ((:name $ :params (:param $*) :fbody _*) *) :body _*) 1432 '(labels ((foo (x y) (list x y)) 1433 (bar (z w) (print z) (print w)) 1434 (quux ())) 1435 (foo 1 2) 1436 (bar 3 4)) 1437 param) 1438 '((x y) (z w) ())) 1439 1440 ;; Extrait une liste associative nom . lambda correspondant aux déclarations, 1441 ;; en rajoutant labels- devant chaque nom de paramètre (juste pour le fun). 1442 (deftest (match capture labels) 1443 (match (labels :declarations ((:name $ :params (:param $*) :fbody _*) *) :body _*) 1444 '(labels ((foo (x y) (list x y)) 1445 (bar (z w) (print z) (print w)) 1446 (quux ())) 1447 (foo 1 2) 1448 (bar 3 4)) 1449 (mapcar (lambda (name params fbody) 1450 `(,name . (lambda ,(mapcar (lambda (param) 1451 (intern (format nil "LABELS-~w" param))) 1452 params) 1453 ,@fbody))) 1454 name params fbody)) 1455 '((foo . (lambda (labels-x labels-y) (list x y))) 1456 (bar . (lambda (labels-z labels-w) (print z) (print w))) 1457 (quux . (lambda ())))) 1458 1459 (deftest (match cond-match) 1460 (cond-match 1461 '(a b) 1462 ((:x $ $) (list 1 x)) 1463 ((:y $ @) (list 2 y)) 1464 ((:z _) (list 3 z))) 1465 '(1 a)) 1466 1467 (deftest (match cond-match) 1468 (cond-match 1469 '(a (b)) 1470 ((:x $ $) (list 1 x)) 1471 ((:y $ @) (list 2 y)) 1472 ((:z _) (list 3 z))) 1473 '(2 a)) 1474 1475 (deftest (match cond-match) 1476 (cond-match 1477 '(x) 1478 ((:x $ $) (list 1 x)) 1479 ((:y $ @) (list 2 y)) 1480 ((:z _) (list 3 z))) 1481 '(3 x)) 1482 1483 1484 (defmatch test-match-foo) 1485 1486 (defmatch test-match-foo (:x $ $) (list 'x x)) 1487 (defmatch test-match-foo (:y $ @) (list 'y y)) 1488 (defmatch test-match-foo (:z _) (list 'z z)) 1489 (defmatch test-match-foo else (x) x 'i-m-else) 1490 1491 (deftest (match defmatch) 1492 (test-match-foo '(a b)) 1493 '(x a)) 1494 1495 (deftest (match defmatch) 1496 (test-match-foo '(a (b))) 1497 '(y a)) 1498 1499 (deftest (match defmatch) 1500 (test-match-foo '((3))) 1501 '(z (3))) 1502 1503 (deftest (match defmatch) 1504 (test-match-foo 42) 1505 'i-m-else) 1506 1507 (defmatch test-match-bar) 1508 (defmatch test-match-bar else 'i-m-else) 1509 (deftest (match defmatch) 1510 (test-match-bar 42) 1511 'i-m-else) 1512 1513 (eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 100%")) 1514 1515 (provide 'match)