-
Notifications
You must be signed in to change notification settings - Fork 10
/
Copy pathmatching.lsp
169 lines (159 loc) · 6.79 KB
/
matching.lsp
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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
;; @module matching
;; @author Jeff Ober <[email protected]>, Kanen Flowers <[email protected]>
;; @version 1.0
;; @location http://static.artfulcode.net/newlisp/matching.lsp
;; @package http://static.artfulcode.net/newlisp/matching.qwerty
;; @description Complex conditionals using match and unify (updated for newlisp 10)
;; <p>Matching conditionals make possible a very terse style of programming common to the
;; ML family of languages.</p>
;; <h4>Version history</h4>
;; <b>1.0</b>
;; • updated for newlisp 10
;; • renamed module to matching
;; • removed dependency on util.lsp
;; • made match-bind a global symbol
;; • fixed error in documentation for match-cond
;; • fixed error in match-cond that bound arguments incorrectly
;; • removed match-with and if-match because they were generally confusing and unnecessary
;; • match-bind no longer binds exact matches (e.g. 'foo and 'foo), only wildcards
;; • fixed bug in match-case where target was bound incorrectly in some cases
;;
;; <b>0.5</b>
;; • fixed bug in 'with-match' causing $0 to be misinterpreted in certain circumstances
;;
;; <b>0.4</b>
;; • added 'with-match', a simpler operator that is more idiomatic of newLISP
;;
;; <b>0.3</b>
;; • added 'if-match', 'match-with'
;;
;; <b>0.2</b>
;; • altered argument order in 'match-cond'
;; • added 'match-case'
;;
;; <b>0.1</b>
;; • initial release
;; • added 'match-bind', 'match-let'
;; @syntax (match-bind <vars> <pattern> <target>)
;; @param <vars> symbols to bind
;; @param <pattern> match pattern
;; @param <target> match target
;; <p>If '(match <pattern> <target>)' is valid, binds <vars> to
;; the result of its evaluation.</p>
;; @example
;; (match-bind '(a b) '(? ?) '(1 2))
;; a => 1
;; b => 2
(define (match-bind var-list pattern target)
(let ((m (match pattern target)))
(map set var-list m)))
(global 'match-bind)
;; @syntax (match-let (<vars> <pattern> <target>) <body> ...)
;; @param <vars> symbols to bind
;; @param <pattern> match pattern
;; @param <target> match target
;; @param <body> series of forms to be evaluated
;; <p>'match-let' will evaluate body in an environment where
;; variables <vars> are bound to the destructured values from
;; <target> according to match pattern <pattern>. Thus, if
;; the result of '(match <pattern> <target>)' is '(1 2 (3 4))',
;; <vars> '(a b c)' will be bound as '((a 1) (b 2) (c '(3 4)))'.</p>
;; <p>Should <pattern> not match <target>, an error is signaled.
;; Note that <target> is evaluated before <body> is executed.
;; <target> is evaluated even if the match fails, as it is the
;; evaluated form against which <pattern> is matched.</p>
;; @example
;; (let ((lst '(1 2 3 4)))
;; (match-let ((a b c) (? ? *) lst)
;; (+ a b (apply * c))))
;;
;; => 15
(define-macro (match-let)
(letex ((var-list (args 0 0))
(pattern (args 0 1))
(target (args 0 2))
(body (cons 'begin (rest (args)))))
(if (match 'pattern target)
(local var-list
(match-bind 'var-list 'pattern target)
body)
(throw-error "no match possible"))))
(global 'match-let)
;; @syntax (match-case <target> (<case-pattern> <case-vars> <case-expr>) ...)
;; @param <target> the expression to match against
;; @param <case-pattern> the pattern to match with <target>
;; @param <case-vars> the symbols to bind to the result of the match
;; @param <case-expr> the form to be evaluated should <case-pattern> match successfully
;; <p>'match-case' tries a series of match cases in sequence and returns the result of
;; evaluating the first successful match's <case-expr> in a local scope in which symbols
;; <case-vars> are bound to the result of matching <case-pattern> against <target>.</p>
;; @example
;; (let ((x '(1 2 3 4 5)))
;; (match-case x
;; ((? ? ?) (a b c) (println "this form is not evaluated since '(? ? ?) does not match x"))
;; ((? ? *) (a b c) (println "c is bound to " c " in this form"))
;; ((*) (a) (println "catch-all")))) ; (*) matches all lists, so it is catch-all for x
;;
;; => "c is bound to (3 4 5) in this form"
(define-macro (match-case)
(let ((target (args 0)))
(catch
(dolist (form (rest (args)))
(letex ((tgt (eval target)) (pattern (form 0)) (vars (form 1)) (expr (form 2)))
(if (match 'pattern 'tgt)
(match-let (vars pattern 'tgt)
(throw expr))))))))
(global 'match-case)
;; @syntax (match-cond ((<pattern> <vars> <target>) <body-forms>) ...)
;; @param <pattern> match pattern
;; @param <vars> symbols to bind
;; @param <target> match target
;; @param <body> series of forms to be evaluated
;; <p>'match-cond' evaluates a series of match/bind combinations until one
;; of them evaluates non-nil. The result of the successful match will be bound
;; to the symbols in <vars>, and the associated <body-forms> will be evaluated
;; with those symbols locally bound. The result of the evaluation is nil if
;; no forms match or the result of the final <body-form> evaluated.</p>
;; <p>'match-cond' is more versatile than 'match-case' in that 'match-cond' may
;; test against multiple targets and evaluates its <body-forms> in an implicit
;; 'begin' block.</p>
;; @example
;; (let ((x '(1 2 3 4 5)))
;; (match-cond
;; (((? ? ?) (a b c) x) (println "evaluation never gets here"))
;; (((? ? *) (a b c) x) (println "c gets bound to " c))
;; (((*) (a) x) (println "catch-all")))) ; (*) matches all lists, so is catch-all for x
;;
;; => "c gets bound to (3 4 5)"
(define-macro (match-cond)
(catch
(doargs (form)
(letex ((pattern (form 0 0))
(vars (form 0 1))
(target (form 0 2))
(body (cons 'begin (rest form))))
(if (match 'pattern target)
(match-let (vars pattern target)
(throw body)))))))
(global 'match-cond)
;; @syntax (with-match <target> (<match-form-n> <body-n>) ...)
;; @param <target> target of the match
;; @param <match-expr-n> match pattern to be tested against <target>
;; @param <body-n> block to be evaluated if <match-expr-n> matches successfully
;; <p>Tests each <match-expr-n> in turn against <target>. On the first successful match,
;; the system variable '$0' is bound to the result of the match and the paired <body-n> is
;; evaluated. No further match forms are tested after a successful match and the result of
;; the evaluation of <body-n> is returned. If no match is successful, 'nil' is returned.</p>
;; @example
;; (with-match '(1 2 3 (4 5))
;; ((? ? ? (? ?)) (apply + $0))
;; ((? *) (println "Never gets here")))
;; => 15
(define-macro (with-match)
(letex ((target (args 0)) (forms (rest (args))))
(catch
(dolist (form 'forms)
(letex ((match-form (first form)) (body (cons 'begin (rest form))))
(let (($0 (match 'match-form target)))
(if $0 (throw body))))))))
(global 'with-match)