/[cl-unification]/cl-unification/match-block.lisp
ViewVC logotype

Contents of /cl-unification/match-block.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Mon Dec 3 15:39:10 2012 UTC (16 months, 2 weeks ago) by mantoniotti
Branch: MAIN
CVS Tags: HEAD
Changes since 1.13: +2 -2 lines
Fixed doc strings in MATCH-CASE and MATCHF-CASE.
1 ;;;; -*- Mode: Lisp -*-
2
3 ;;;; match-block.lisp --
4 ;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.
5
6 ;;;; See file COPYING for copyright licensing information.
7
8 (in-package "UNIFY")
9
10 (defun clean-unify-var-name (v)
11 (assert (variablep v))
12 (intern (subseq (symbol-name v) 1)
13 (symbol-package v)))
14
15
16 (defmacro match ((template object
17 &key
18 (match-named nil)
19 (substitution '(make-empty-environment))
20 (errorp t)
21 (error-value nil))
22 &body forms)
23 "Sets up a lexical environment to evaluate FORMS after an unification.
24
25 MATCH unifies a TEMPLATE and an OBJECT and then sets up a lexical
26 environment where the variables present in the template are bound
27 lexically. Note that both variable names '?FOO' and 'FOO' are bound
28 for convenience.
29
30 The MATCH form returns the values returned by the evaluation of the
31 last of the FORMS.
32
33 If ERRORP is non-NIL (the default) then the form raises a
34 UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
35 whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
36 raising from the evaluation of FORMS will also be caught and handled
37 according to ERRORP settings.)
38
39 If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
40 is set up around the matching code.
41 "
42 (let ((template-vars (collect-template-vars template))
43 (env-var (gensym "UNIFICATION-ENV-"))
44 (template (if (variablep template)
45 `',template ; Logical variables are special-cased.
46 template))
47 )
48 (flet ((generate-var-bindings ()
49 (loop for v in template-vars
50 nconc (list `(,v (find-variable-value ',v
51 ,env-var))
52 `(,(clean-unify-var-name v) ,v))))
53 )
54 `(block ,match-named
55 (handler-case
56 (let* ((,env-var (unify ,template ,object ,substitution))
57 ,@(generate-var-bindings)
58 )
59 (declare (ignorable ,@(mapcar #'first
60 (generate-var-bindings))))
61 ,@forms)
62
63 ;; Yes. The above is sligthly wasteful.
64
65 (unification-failure (uf)
66 (if ,errorp
67 (error uf)
68 ,error-value))
69 )))))
70
71
72 (defmacro matchf ((template object
73 &key
74 (match-named nil)
75 (substitution '(make-empty-environment))
76 (errorp t)
77 (error-value nil))
78 &body forms)
79 "Sets up a lexical environment to evaluate FORMS after an unification.
80
81 MATCHF unifies a TEMPLATE and an OBJECT and then sets up a lexical
82 environment where the variables present in the template are bound
83 lexically. Note that both variable names '?FOO' and 'FOO' are bound
84 for convenience.
85
86 MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will
87 generate a template at read-time).
88
89 The MATCHF form returns the values returned by the evaluation of the
90 last of the FORMS.
91
92 If ERRORP is non-NIL (the default) then the form raises a
93 UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
94 whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
95 raising from the evaluation of FORMS will also be caught and handled
96 according to ERRORP settings.)
97
98 If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
99 is set up around the matching code.
100 "
101 (let ((template-vars (collect-template-vars template))
102 (env-var (gensym "UNIFICATION-ENV-"))
103 (template (cond ((variablep template)
104 `',template) ; Logical variables are special-cased.
105 ((listp template) ; Same for lists.
106 (make-instance 'list-template
107 :spec (cons 'list template)))
108 ;`',template)
109 (t
110 template)))
111 )
112 ;; Logical variables and lists are special cased for convenience.
113 ;; Lists are especially inteded as abbreviation for destructuring.
114 (flet ((generate-var-bindings ()
115 (loop for v in template-vars
116 nconc (list `(,v (find-variable-value ',v
117 ,env-var))
118 `(,(clean-unify-var-name v) ,v))))
119 )
120 `(block ,match-named
121 (handler-case
122 (let* ((,env-var (unify ,template ,object ,substitution))
123 ,@(generate-var-bindings)
124 )
125 (declare (ignorable ,@(mapcar #'first
126 (generate-var-bindings))))
127 ,@forms)
128
129 ;; Yes. The above is sligthly wasteful.
130
131 (unification-failure (uf)
132 (if ,errorp
133 (error uf)
134 ,error-value))
135 )))))
136
137
138
139 (define-condition unification-non-exhaustive (unification-failure)
140 ())
141
142
143 (defmacro matching ((&key errorp
144 (default-substitution
145 (make-empty-environment))
146 (matching-named nil))
147 &rest match-clauses)
148 "MATCHING sets up a COND-like environment for multiple template matching clauses.
149
150 The syntax of MATCHING comprises a number of clauses of the form
151
152 <clause> ::= <regular-clause> | <default-clause>
153 <regular-clause> ::= ((<template> <form>) &body <forms>)
154 <default-clause> ::= (t &body <forms>)
155 | (otherwise &body <forms>)
156 <form> and <forms> are regular Common Lisp forms.
157 <template> is a unification template.
158
159 The full syntax of MATCHING is
160
161 matching (&key errorp default-substitution) <clauses>
162
163 Each clause evaluates its forms in an environment where the variables
164 present in the template are bound lexically. Note that both variable
165 names '?FOO' and 'FOO' are bound for convenience.
166
167 The values returned by the MATCHING form are those of the last form in
168 the first clause that satisfies the match test.
169
170 If ERRORP is non-NIL then if none of the regular clauses matches, then
171 an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
172 any default clause. Otherwise, the default clause behaves as a
173 standard COND default clause. The default value of ERRORP is NIL.
174 "
175 (declare (ignore default-substitution)) ; For the time being.
176 (labels ((%%match%% (clause-var template object forms substitution)
177 (let ((template-vars (collect-template-vars template))
178 (template (if (variablep template)
179 `',template ; Logical variables are
180 ; special-cased.
181 template))
182 )
183 (flet ((generate-var-bindings ()
184 (loop for v in template-vars
185 nconc (list `(,v (find-variable-value
186 ',v
187 ,clause-var))
188 `(,(clean-unify-var-name v) ,v))))
189 )
190 `((setf ,clause-var
191 (ignore-errors (unify ,template
192 ,object
193 ,substitution)))
194 (let* (,@(generate-var-bindings))
195 ,@forms))
196 )))
197
198 (build-match-clause (match-clause match-env-var)
199 (destructuring-bind ((template object) &body forms)
200 match-clause
201 (%%match%% match-env-var
202 template
203 object
204 forms
205 '(make-empty-environment))))
206 )
207 (when (or (and (find t match-clauses :key #'first)
208 (find 'otherwise match-clauses :key #'first))
209 (> (count t match-clauses :key #'first) 1)
210 (> (count 'otherwise match-clauses :key #'first) 1))
211 (error 'program-error))
212 (let* ((default-clause (or (find t match-clauses
213 :key #'first)
214 (find 'otherwise match-clauses
215 :key #'first)))
216 (match-clauses (delete default-clause match-clauses)) ; EQL
217 ; test
218 ; suffices.
219 (match-clauses-env-vars (mapcar (lambda (mc)
220 (declare (ignore mc))
221 (gensym "UNIFICATION-ENV-")
222 )
223 match-clauses))
224 )
225
226 `(block ,matching-named
227 (let ,match-clauses-env-vars
228 (declare (dynamic-extent ,@match-clauses-env-vars))
229 (cond ,@(mapcar (lambda (match-clause match-clause-env-var)
230 (build-match-clause match-clause
231 match-clause-env-var))
232 match-clauses
233 match-clauses-env-vars)
234 (,errorp
235 (error 'unification-non-exhaustive
236 :format-control "Non exhaustive matching."))
237 ,@(when default-clause (list default-clause))))))
238 ))
239
240
241 ;;; match-case --
242 ;;; Implementation provided by Peter Scott.
243 ;;;
244 ;;; Notes:
245 ;;;
246 ;;; [MA 20071109]
247 ;;; The construction of the inner MATCH clauses could be done
248 ;;; more intelligently by supplying :ERRORP NIL, thus avoiding the
249 ;;; HANDLER-CASEs, which are quite expensive. Any takers?
250
251 (defmacro match-case ((object &key errorp default-substitution match-case-named)
252 &body clauses)
253 "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.
254
255 The syntax of MATCH-CASE comprises a number of clauses of the form
256
257 <clause> ::= <regular-clause> | <default-clause>
258 <regular-clause> ::= (<template> &body <forms>)
259 <default-clause> ::= (t &body <forms>)
260 | (otherwise &body <forms>)
261 <form> and <forms> are regular Common Lisp forms.
262 <template> is a unification template.
263
264 The full syntax of MATCH-CASE is
265
266 match-case (<object> &key errorp default-substitution) <clauses>
267
268 Each clause evaluates its forms in an environment where the variables
269 present in the template are bound lexically. Note that both variable
270 names '?FOO' and 'FOO' are bound for convenience.
271
272 The values returned by the MATCH-CASE form are those of the last form in
273 the first clause that satisfies the match test.
274
275 If ERRORP is non-NIL then if none of the regular clauses matches, then
276 an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
277 any default clause. Otherwise, the default clause behaves as a
278 standard CASE default clause. The default value of ERRORP is NIL.
279 "
280 (declare (ignore default-substitution)) ; For the time being.
281 (let* ((object-var (gensym "OBJECT-VAR-"))
282 (otherwise-clause-present-p
283 (member (caar (last clauses)) '(t otherwise)))
284 (non-otherwise-clauses
285 (if otherwise-clause-present-p
286 (butlast clauses)
287 clauses))
288 (otherwise-clause
289 (if otherwise-clause-present-p
290 (first (last clauses))
291 (when errorp
292 `(t (error 'unification-non-exhaustive
293 :format-control "Non exhaustive matching.")))))
294 )
295 (labels ((generate-matchers (clauses)
296 (if (null clauses)
297 `(progn ,@(rest otherwise-clause))
298 (destructuring-bind (pattern &rest body)
299 (car clauses)
300 `(handler-case (match (,pattern ,object-var)
301 ,@body)
302 (unification-failure ()
303 ,(generate-matchers (cdr clauses))))))))
304 `(block ,match-case-named
305 (let ((,object-var ,object))
306 ,(generate-matchers non-otherwise-clauses))))))
307
308
309 (defmacro matchf-case ((object &key errorp default-substitution match-case-named)
310 &body clauses)
311 "MATCHF-CASE sets up a CASE-like environment for multiple template matching clauses.
312
313 The syntax of MATCHF-CASE comprises a number of clauses of the form
314
315 <clause> ::= <regular-clause> | <default-clause>
316 <regular-clause> ::= (<template> &body <forms>)
317 <default-clause> ::= (t &body <forms>)
318 | (otherwise &body <forms>)
319 <form> and <forms> are regular Common Lisp forms.
320 <template> is a unification template.
321
322 The full syntax of MATCHF-CASE is
323
324 matchf-case (<object> &key errorp default-substitution) <clauses>
325
326 Each clause evaluates its forms in an environment where the variables
327 present in the template are bound lexically. Note that both variable
328 names '?FOO' and 'FOO' are bound for convenience.
329
330 The values returned by the MATCH-CASE form are those of the last form in
331 the first clause that satisfies the match test.
332
333 If ERRORP is non-NIL then if none of the regular clauses matches, then
334 an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
335 any default clause. Otherwise, the default clause behaves as a
336 standard CASE default clause. The default value of ERRORP is NIL.
337
338 MATCHF-CASE behaves like MATCH-CASE, but the patterns are not
339 evaluated (i.e., it relies on MATCHF instead of MATCH to construct the
340 macro expansion.
341 "
342 (declare (ignore default-substitution)) ; For the time being.
343 (let* ((object-var (gensym "OBJECT-VAR-"))
344 (otherwise-clause-present-p
345 (member (caar (last clauses)) '(t otherwise)))
346 (non-otherwise-clauses
347 (if otherwise-clause-present-p
348 (butlast clauses)
349 clauses))
350 (otherwise-clause
351 (if otherwise-clause-present-p
352 (first (last clauses))
353 (when errorp
354 `(t (error 'unification-non-exhaustive
355 :format-control "Non exhaustive matching.")))))
356 )
357 (labels ((generate-matchers (clauses)
358 (if (null clauses)
359 `(progn ,@(rest otherwise-clause))
360 (destructuring-bind (pattern &rest body)
361 (car clauses)
362 `(handler-case (matchf (,pattern ,object-var)
363 ,@body)
364 (unification-failure ()
365 ,(generate-matchers (cdr clauses))))))))
366 `(block ,match-case-named
367 (let ((,object-var ,object))
368 ,(generate-matchers non-otherwise-clauses))))))
369
370 ;;;;---------------------------------------------------------------------------
371 ;;;; Testing.
372
373 #| Tests
374
375 (let ((n 42))
376 (matching ()
377 ((0 n) 1)
378 ((?x n) (* x (1- x)))))
379
380
381 (let ((n 42))
382 (match-case (n)
383 (0 1)
384 (?x (* x (1- x)))))
385
386
387 (let ((n 42))
388 (match-case (n)
389 (0 1)
390 (otherwise (* n (1- n)))))
391
392 (defun fatt (x)
393 (match-case (x :errorp t)
394 (0 1)
395 (#T(number ?n) (* ?n (fatt (1- n))))
396 ))
397
398 |#
399
400 ;;;; end of file -- math-blocks.lisp --

  ViewVC Help
Powered by ViewVC 1.1.5