blob: 493f4b2d76ae9f65521b66a449f5d9b34ab2e9b1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
(load "../common")
(test (if-match 1 1 'yes 'no) yes)
(test (if-match 1 0 'yes 'no) no)
(test (let ((sym 'a))
(list (if-match a sym 'yes 'no)
(if-match b sym 'yes 'no)))
(yes no))
(test (when-match @a 42 (list a)) (42))
(test (when-match (@a @b @c) '(1 2 3) (list c b a)) (3 2 1))
(test (if-match (@a @b @c . @d) '(1 2 3 . 4) (list d c b a)) (4 3 2 1))
(test (if-match (@(oddp a) @b @c . @d) '(2 x y z)
(list a b c d)
:no-match)
:no-match)
(test (if-match (1 2 . @a) '(1 2 3 4) a) (3 4))
(test (if-match ((1 2 @a) @b) '((1 2 3) 4) (list a b)) (3 4))
(test (if-match #() #() :yes :no) :yes)
(test (if-match #() #(1) :yes :no) :no)
(test (if-match #((1 @a) #(3 @b)) #((1 2) #(3 4)) (list a b)) (2 4))
(test (when-match @(struct time year 2021 month @m) #S(time year 2021 month 1)
m)
1)
(defstruct widget ()
name
value)
(defstruct grommet ()
name
value)
(vtest (append-each ((obj (list (new grommet name "foo" value :grom)
(new widget name "foo" value :widg))))
(when-match @(struct @type name "foo" value @v) obj
(list (list type v))))
^((,(find-struct-type 'grommet) :grom)
(,(find-struct-type 'widget) :widg)))
(test (when-match @(let w (@a @b @c)) '(1 2 3) (list w a b c)) ((1 2 3) 1 2 3))
(test (when-match @(require (+ @a @b) (equal a b)) '(+ z z) (list a b)) (z z))
(test (if-match @(require (+ @a @b) (equal a b)) '(+ y z)
(list a b)
:no-match)
:no-match)
(test (when-match @(all (x @a @b)) '((x 1 a) (x 2 b) (x 3 c))
(list a b))
((1 2 3) (a b c)))
(test (when-match @(some (x @a @b)) '((y 1 a) (x 2 b) (z 3 c))
(list a b))
(2 b))
(test (if-match @(and (@x 2 3) (1 @y 3) (1 2 @z)) '(1 2 3)
(list x y z))
(1 2 3))
(test (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2)
(test (if-match @(op <= 10 @1 13) 11 :yes :no) :yes)
(test (when-match @(let x @(op <= 10 @1 13)) 11 x) 11)
(test (when-match (@(evenp) @(oddp x)) '(2 3) x) 3)
(test
(collect-each ((obj (list '(1 2 3)
'(4 5)
'(3 5)
#S(time year 2021 month 1 day 1)
#(vec tor))))
(match-case obj
(@(struct time year @y) y)
(#(@x @y) (list x y))
((@nil @nil @x) x)
((4 @x) x)
((@x 5) x)))
(3 5 3 2021 (vec tor)))
(test (when-match (@(and @a @b) (x . @c)) '(1 (x 2 3 4)) c) (2 3 4))
(test (when-match (@(some @a) . @b) '((1 2 3) 2) (list a b)) (1 (2)))
(set *print-circle* t)
(test (when-match @(let a @(some @a)) '#1=(1 2 #1# 3) :yes) :yes)
(test (when-match (@a @(let a @(some @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes)
(test (when-match (@a @(let a @(or x @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes)
(defstruct node ()
left right)
(mlet ((n (lnew node left (new node left n))))
(test (when-match @(let x @(struct node
left @(struct node left @x)))
n :yes)
:yes))
(test
(collect-each ((obj (list '(1 2 3)
'(4 5)
'(3 5)
'(6 2 6)
#(11 12)
#S(time year 2021 month 1 day 2)
#S(time year 2020 month 1 day 1)
#(vec tor))))
(match-case obj
(@(struct @s year 2021 day @d) (list d (struct-type-name s)))
(@(struct time year @y month @x day @x) (list y x))
(#(@(integerp x) @(require @y (succ x))) (list x y))
(#(@x @y) (list x y))
((@x @nil @x) x)
((@nil @nil @x) x)
((4 @x) x)
((@x 5) x)))
(3 5 3 6 (11 12) (2 time) (2020 1) (vec tor)))
|
