Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 169 lines (159 sloc) 6.955 kb
e9950d99 »
2011-08-16 first commit
1 ;; @module matching
e2bb587d »
2011-08-16 Ego commit
2 ;; @author Jeff Ober <jeffober@gmail.com>, Kanen Flowers <kanendosei@gmail.com>
e9950d99 »
2011-08-16 first commit
3 ;; @version 1.0
4 ;; @location http://static.artfulcode.net/newlisp/matching.lsp
5 ;; @package http://static.artfulcode.net/newlisp/matching.qwerty
6 ;; @description Complex conditionals using match and unify (updated for newlisp 10)
7 ;; <p>Matching conditionals make possible a very terse style of programming common to the
8 ;; ML family of languages.</p>
9 ;; <h4>Version history</h4>
10 ;; <b>1.0</b>
11 ;; &bull; updated for newlisp 10
12 ;; &bull; renamed module to matching
13 ;; &bull; removed dependency on util.lsp
14 ;; &bull; made match-bind a global symbol
15 ;; &bull; fixed error in documentation for match-cond
16 ;; &bull; fixed error in match-cond that bound arguments incorrectly
17 ;; &bull; removed match-with and if-match because they were generally confusing and unnecessary
18 ;; &bull; match-bind no longer binds exact matches (e.g. 'foo and 'foo), only wildcards
19 ;; &bull; fixed bug in match-case where target was bound incorrectly in some cases
20 ;;
21 ;; <b>0.5</b>
22 ;; &bull; fixed bug in 'with-match' causing $0 to be misinterpreted in certain circumstances
23 ;;
24 ;; <b>0.4</b>
25 ;; &bull; added 'with-match', a simpler operator that is more idiomatic of newLISP
26 ;;
27 ;; <b>0.3</b>
28 ;; &bull; added 'if-match', 'match-with'
29 ;;
30 ;; <b>0.2</b>
31 ;; &bull; altered argument order in 'match-cond'
32 ;; &bull; added 'match-case'
33 ;;
34 ;; <b>0.1</b>
35 ;; &bull; initial release
36 ;; &bull; added 'match-bind', 'match-let'
37
38 ;; @syntax (match-bind <vars> <pattern> <target>)
39 ;; @param <vars> symbols to bind
40 ;; @param <pattern> match pattern
41 ;; @param <target> match target
42 ;; <p>If '(match <pattern> <target>)' is valid, binds <vars> to
43 ;; the result of its evaluation.</p>
44 ;; @example
45 ;; (match-bind '(a b) '(? ?) '(1 2))
46 ;; a => 1
47 ;; b => 2
48 (define (match-bind var-list pattern target)
49 (let ((m (match pattern target)))
50 (map set var-list m)))
51
52 (global 'match-bind)
53
54 ;; @syntax (match-let (<vars> <pattern> <target>) <body> ...)
55 ;; @param <vars> symbols to bind
56 ;; @param <pattern> match pattern
57 ;; @param <target> match target
58 ;; @param <body> series of forms to be evaluated
59 ;; <p>'match-let' will evaluate body in an environment where
60 ;; variables <vars> are bound to the destructured values from
61 ;; <target> according to match pattern <pattern>. Thus, if
62 ;; the result of '(match <pattern> <target>)' is '(1 2 (3 4))',
63 ;; <vars> '(a b c)' will be bound as '((a 1) (b 2) (c '(3 4)))'.</p>
64 ;; <p>Should <pattern> not match <target>, an error is signaled.
65 ;; Note that <target> is evaluated before <body> is executed.
66 ;; <target> is evaluated even if the match fails, as it is the
67 ;; evaluated form against which <pattern> is matched.</p>
68 ;; @example
69 ;; (let ((lst '(1 2 3 4)))
70 ;; (match-let ((a b c) (? ? *) lst)
71 ;; (+ a b (apply * c))))
72 ;;
73 ;; => 15
74 (define-macro (match-let)
75 (letex ((var-list (args 0 0))
76 (pattern (args 0 1))
77 (target (args 0 2))
78 (body (cons 'begin (rest (args)))))
79 (if (match 'pattern target)
80 (local var-list
81 (match-bind 'var-list 'pattern target)
82 body)
83 (throw-error "no match possible"))))
84
85 (global 'match-let)
86
87 ;; @syntax (match-case <target> (<case-pattern> <case-vars> <case-expr>) ...)
88 ;; @param <target> the expression to match against
89 ;; @param <case-pattern> the pattern to match with <target>
90 ;; @param <case-vars> the symbols to bind to the result of the match
91 ;; @param <case-expr> the form to be evaluated should <case-pattern> match successfully
92 ;; <p>'match-case' tries a series of match cases in sequence and returns the result of
93 ;; evaluating the first successful match's <case-expr> in a local scope in which symbols
94 ;; <case-vars> are bound to the result of matching <case-pattern> against <target>.</p>
95 ;; @example
96 ;; (let ((x '(1 2 3 4 5)))
97 ;; (match-case x
98 ;; ((? ? ?) (a b c) (println "this form is not evaluated since '(? ? ?) does not match x"))
99 ;; ((? ? *) (a b c) (println "c is bound to " c " in this form"))
100 ;; ((*) (a) (println "catch-all")))) ; (*) matches all lists, so it is catch-all for x
101 ;;
102 ;; => "c is bound to (3 4 5) in this form"
103 (define-macro (match-case)
104 (let ((target (args 0)))
105 (catch
106 (dolist (form (rest (args)))
107 (letex ((tgt (eval target)) (pattern (form 0)) (vars (form 1)) (expr (form 2)))
108 (if (match 'pattern 'tgt)
109 (match-let (vars pattern 'tgt)
110 (throw expr))))))))
111
112 (global 'match-case)
113
114 ;; @syntax (match-cond ((<pattern> <vars> <target>) <body-forms>) ...)
115 ;; @param <pattern> match pattern
116 ;; @param <vars> symbols to bind
117 ;; @param <target> match target
118 ;; @param <body> series of forms to be evaluated
119 ;; <p>'match-cond' evaluates a series of match/bind combinations until one
120 ;; of them evaluates non-nil. The result of the successful match will be bound
121 ;; to the symbols in <vars>, and the associated <body-forms> will be evaluated
122 ;; with those symbols locally bound. The result of the evaluation is nil if
123 ;; no forms match or the result of the final <body-form> evaluated.</p>
124 ;; <p>'match-cond' is more versatile than 'match-case' in that 'match-cond' may
125 ;; test against multiple targets and evaluates its <body-forms> in an implicit
126 ;; 'begin' block.</p>
127 ;; @example
128 ;; (let ((x '(1 2 3 4 5)))
129 ;; (match-cond
130 ;; (((? ? ?) (a b c) x) (println "evaluation never gets here"))
131 ;; (((? ? *) (a b c) x) (println "c gets bound to " c))
132 ;; (((*) (a) x) (println "catch-all")))) ; (*) matches all lists, so is catch-all for x
133 ;;
134 ;; => "c gets bound to (3 4 5)"
135 (define-macro (match-cond)
136 (catch
137 (doargs (form)
138 (letex ((pattern (form 0 0))
139 (vars (form 0 1))
140 (target (form 0 2))
141 (body (cons 'begin (rest form))))
142 (if (match 'pattern target)
143 (match-let (vars pattern target)
144 (throw body)))))))
145
146 (global 'match-cond)
147
148 ;; @syntax (with-match <target> (<match-form-n> <body-n>) ...)
149 ;; @param <target> target of the match
150 ;; @param <match-expr-n> match pattern to be tested against <target>
151 ;; @param <body-n> block to be evaluated if <match-expr-n> matches successfully
152 ;; <p>Tests each <match-expr-n> in turn against <target>. On the first successful match,
153 ;; the system variable '$0' is bound to the result of the match and the paired <body-n> is
154 ;; evaluated. No further match forms are tested after a successful match and the result of
155 ;; the evaluation of <body-n> is returned. If no match is successful, 'nil' is returned.</p>
156 ;; @example
157 ;; (with-match '(1 2 3 (4 5))
158 ;; ((? ? ? (? ?)) (apply + $0))
159 ;; ((? *) (println "Never gets here")))
160 ;; => 15
161 (define-macro (with-match)
162 (letex ((target (args 0)) (forms (rest (args))))
163 (catch
164 (dolist (form 'forms)
165 (letex ((match-form (first form)) (body (cons 'begin (rest form))))
166 (let (($0 (match 'match-form target)))
167 (if $0 (throw body))))))))
168
169 (global 'with-match)
Something went wrong with that request. Please try again.