1(import (chicken load)) 2 3(load-relative "test.scm") 4 5;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6;; run tests 7 8(test-begin "match") 9 10(test-equal "any" (match 'any (_ 'ok)) 'ok) 11(test-equal "symbol" (match 'ok (x x)) 'ok) 12(test-equal "number" (match 28 (28 'ok)) 'ok) 13(test-equal "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok) 14(test-equal "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok) 15(test-equal "null" (match '() (() 'ok)) 'ok) 16(test-equal "pair" (match '(ok) ((x) x)) 'ok) 17(test-equal "vector" (match '#(ok) (#(x) x)) 'ok) 18(test-equal "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok) 19(test-equal "and empty" (match '(o k) ((and) 'ok)) 'ok) 20(test-equal "and single" (match 'ok ((and x) x)) 'ok) 21(test-equal "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok) 22(test-equal "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok) 23(test-equal "or single" (match 'ok ((or x) 'ok)) 'ok) 24(test-equal "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok) 25(test-equal "not" (match 28 ((not (a . b)) 'ok)) 'ok) 26(test-equal "pred" (match 28 ((? number?) 'ok)) 'ok) 27(test-equal "named pred" (match 28 ((? number? x) (+ x 1))) 29) 28 29(test-equal "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok) 30(test-equal "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok) 31(test-equal "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok) 32 33(test-equal "ellipses" 34 (match '((a . 1) (b . 2) (c . 3)) 35 (((x . y) ___) (list x y))) 36 '((a b c) (1 2 3))) 37 38(test-equal "real ellipses" 39 (match '((a . 1) (b . 2) (c . 3)) 40 (((x . y) ...) (list x y))) 41 '((a b c) (1 2 3))) 42 43(test-equal "vector ellipses" 44 (match '#(1 2 3 (a . 1) (b . 2) (c . 3)) 45 (#(a b c (hd . tl) ...) (list a b c hd tl))) 46 '(1 2 3 (a b c) (1 2 3))) 47 48(test-equal "pred ellipses" 49 (match '(1 2 3) 50 (((? odd? n) ___) n) 51 (((? number? n) ___) n)) 52 '(1 2 3)) 53 54(test-equal "failure continuation" 55 (match '(1 2) 56 ((a . b) (=> next) (if (even? a) 'fail (next))) 57 ((a . b) 'ok)) 58 'ok) 59 60(test-equal "let" 61 (match-let ((x 'ok) (y '(o k))) 62 y) 63 '(o k)) 64 65(test-equal "let*" 66 (match-let* ((x 'f) (y 'o) ((z w) (list y x))) 67 (list x y z w)) 68 '(f o o f)) 69 70(test-equal "getter car" 71 (match '(1 . 2) (((get! a) . b) (list (a) b))) 72 '(1 2)) 73 74(test-equal "getter cdr" 75 (match '(1 . 2) ((a . (get! b)) (list a (b)))) 76 '(1 2)) 77 78(test-equal "getter vector" 79 (match '#(1 2 3) (#((get! a) b c) (list (a) b c))) 80 '(1 2 3)) 81 82(test-equal "setter car" 83 (let ((x '(1 . 2))) 84 (match x (((set! a) . b) (a 3))) 85 x) 86 '(3 . 2)) 87 88(test-equal "setter cdr" 89 (let ((x '(1 . 2))) 90 (match x ((a . (set! b)) (b 3))) 91 x) 92 '(1 . 3)) 93 94(test-equal "setter vector" 95 (let ((x '#(1 2 3))) 96 (match x (#(a (set! b) c) (b 0))) 97 x) 98 '#(1 0 3)) 99 100(test-equal "single tail" 101 (match '((a . 1) (b . 2) (c . 3)) 102 (((x . y) ... last) (list x y last))) 103 '((a b) (1 2) (c . 3))) 104 105(test-equal "single tail 2" 106 (match '((a . 1) (b . 2) 3) 107 (((x . y) ... last) (list x y last))) 108 '((a b) (1 2) 3)) 109 110(test-equal "multiple tail" 111 (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) 112 (((x . y) ... u v w) (list x y u v w))) 113 '((a b) (1 2) (c . 3) (d . 4) (e . 5))) 114 115(test-equal "Riastradh quasiquote" 116 (match '(1 2 3) (`(1 ,b ,c) (list b c))) 117 '(2 3)) 118 119(test-end "match") 120 121(test-exit) 122