repos
/
cl-unification
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Minor changes (added COPYING information and other minutiae).
Annotate for file /match-block.lisp
2007-11-09 mantoniotti
1
;;;; -*- Mode: Lisp -*-
13:43:20 '
2
'
3
;;;; match-block.lisp --
'
4
;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.
2004-11-17 mantoniotti
5
2011-04-02 mantoniotti
6
;;;; See file COPYING for copyright licensing information.
04:05:18 '
7
2004-11-17 mantoniotti
8
(in-package "UNIFY")
22:19:54 '
9
'
10
(defun clean-unify-var-name (v)
'
11
(assert (variablep v))
'
12
(intern (subseq (symbol-name v) 1)
'
13
(symbol-package v)))
'
14
2010-06-15 pix
15
(defmacro with-unification-variables ((&rest variables) environment &body body)
03:21:37 '
16
"Execute body with variables bound to their values in environment."
'
17
(flet ((variable-bindings (v)
'
18
`((,v (find-variable-value ',v ,environment))
'
19
(,(clean-unify-var-name v) ,v))))
'
20
`(let* ,(mapcan #'variable-bindings variables)
'
21
(declare (ignorable ,@(mapcar #'clean-unify-var-name variables)))
'
22
,@body)))
'
23
2010-02-04 pix
24
(defun %match-expander (template-munger clause-munger clauses
07:32:18 '
25
&key default named environment errorp error-form keyform)
'
26
"A rather hairy internal function which handles expansion for all the MATCH* macros.
2004-11-17 mantoniotti
27
2010-02-04 pix
28
template-munger should be either 'match or 'matchf, and will massage the
07:32:18 '
29
template into the proper form for that macro set.
'
30
'
31
clause-munger should be either 'cond, 'case, or 'nil. This affects the expected
'
32
syntax of items in clauses as follows:
'
33
'cond: { ((<template> <object>) &body) }+ default-clause
'
34
'case: { (<template> &body) }+ default-clause
'
35
'nil: { (<template> <object> &body) }+ default-clause
'
36
default-clause: [ (t &body) ]
'
37
'
38
clauses is a list of forms conforming to the syntax just described.
'
39
'
40
default is a single form to be executed if no other forms match.
'
41
named is the name for a surrounding block.
'
42
'
43
environment is a base environment object which template matches should extend.
'
44
The new environments created will share frames with this environment, though any
'
45
additional bindings will be in a new, unshared frame. environment defaults to
'
46
'(make-empty-environment).
'
47
'
48
errorp is a single form which will be evaluated to determine if error-form is
'
49
executed.
'
50
'
51
error-form is a form which is expected to generate an error (e.g., `(error
'
52
'unification-non-exhaustive)). It defaults to providing the error returned by
'
53
the last form which failed unification.
'
54
'
55
keyform should be used only for a clause-munger of 'case. It provides the form
'
56
to evaluate to produce the object for unification in -case macros.
'
57
'
58
*Interaction between default-clause, :errorp + :error-form, and :default
'
59
'
60
This function produces a giant COND form which ends one or more of these
'
61
assorted \"default\" clauses. They are produced in a very specific order:
'
62
1. errorp + error-form are tried first. Thus, if errorp is 't, neither the
'
63
default-clause in clauses will be reached, nor the :default clause. This is
'
64
essentially a hook to produce a pre-user default clause. (e.g., for
'
65
MATCH's :errorp)
'
66
2. The default-clause in clauses, if it exists, will be tried next. Because
'
67
clauses is expected to contain user-specified clauses, this is expected to be
'
68
the user-specified default clause.
'
69
3. Finally, the :default clause, if specified, will be tried. This is
'
70
essentially a hook to produce a post-user default clause. (e.g., for
'
71
-ECASE's error form)
'
72
"
'
73
(flet ((default-clause-p (clause) (member (first clause) '(t otherwise))))
'
74
(let ((match-environment (gensym "MATCH-ENV-"))
'
75
(base-environment (gensym "BASE-ENV-"))
'
76
(match-error (gensym "MATCH-ERR-"))
'
77
(case-keyform (gensym "KEYFORM-"))
'
78
(match-clauses (remove-if #'default-clause-p clauses))
'
79
(default-clauses (remove-if-not #'default-clause-p clauses)))
'
80
(when (or (and (< 1 (length default-clauses))
'
81
;; whether the default clause is the last one
'
82
(every #'eq clauses (append match-clauses default-clauses)))
'
83
;; :keyform only applies for 'case
'
84
(and keyform (not (eq clause-munger 'case))))
'
85
(error 'program-error))
'
86
(labels ((ensure-template (template)
'
87
(cond (;; Logical variables are special-cased.
'
88
(variablep template) `',template)
'
89
;; Same for lists (under matchf)
'
90
((and (eq 'matchf template-munger)
'
91
(listp template))
'
92
(make-instance 'list-template
'
93
:spec (cons 'list template)))
'
94
(t template)))
'
95
(expand-clause (clause)
'
96
(destructuring-bind (template object &rest body)
2010-02-07 pix
97
(munge-clause clause)
2010-02-04 pix
98
(let* ((template (ensure-template template))
07:32:18 '
99
(variables (collect-template-vars template)))
'
100
`((setf (values ,match-environment ,match-error)
'
101
(unify* ,template ,object (make-expanded-environment ,base-environment)))
2010-06-15 pix
102
(with-unification-variables ,variables ,match-environment
2010-02-04 pix
103
,@body)))))
07:32:18 '
104
(munge-clause (clause)
'
105
(ecase clause-munger
'
106
(cond (destructuring-bind (head . tail) clause
'
107
(if (consp head)
'
108
(list* (car head) (cadr head) tail)
'
109
clause)))
'
110
(case (list* (car clause) case-keyform (cdr clause)))
'
111
((nil) clause))))
'
112
`(block ,named
'
113
(let ((,match-environment nil)
'
114
(,match-error nil)
'
115
(,case-keyform ,keyform)
'
116
(,base-environment ,(if environment
'
117
`(make-shared-environment ,environment)
'
118
'(make-empty-environment))))
'
119
(declare (dynamic-extent ,match-environment ,base-environment)
'
120
(ignorable ,case-keyform))
'
121
(cond
2010-02-07 pix
122
,@(mapcar #'expand-clause match-clauses)
2010-02-04 pix
123
,@(when errorp `((,errorp ,(or error-form `(error ,match-error)))))
07:32:18 '
124
,@(when default-clauses `((t ,@(cdar default-clauses))))
'
125
,@(when default `((t ,default))))))))))
2010-01-12 pix
126
2010-02-05 pix
127
(defmacro %set-documentation ((&rest symbols) docstring)
03:21:40 '
128
`(eval-when (:load-toplevel :execute)
'
129
(mapcar (lambda (fn) (setf (documentation fn 'function) ,docstring))
'
130
',symbols)))
'
131
2004-11-17 mantoniotti
132
(defmacro match ((template object
22:19:54 '
133
&key
2010-02-04 pix
134
(named nil)
07:32:18 '
135
(match-named nil match-named-p)
'
136
(substitution nil)
2004-11-17 mantoniotti
137
(errorp t)
22:19:54 '
138
(error-value nil))
'
139
&body forms)
2010-02-04 pix
140
(when match-named-p
07:32:18 '
141
(warn ":match-named is deprecated. Use :named instead."))
'
142
(%match-expander 'match
'
143
'nil
'
144
`((,template ,object ,@forms))
'
145
:default error-value
'
146
:named (or named match-named)
'
147
:environment substitution
'
148
:errorp errorp))
2009-04-15 mantoniotti
149
10:16:24 '
150
(defmacro matchf ((template object
'
151
&key
2010-02-04 pix
152
(named nil)
07:32:18 '
153
(match-named nil match-named-p)
'
154
(substitution nil)
2009-04-15 mantoniotti
155
(errorp t)
10:16:24 '
156
(error-value nil))
'
157
&body forms)
2010-02-05 pix
158
(when match-named-p
03:21:40 '
159
(warn ":match-named is deprecated. Use :named instead."))
'
160
(%match-expander 'matchf
'
161
'nil
'
162
`((,template ,object ,@forms))
'
163
:default error-value
'
164
:named (or named match-named)
'
165
:environment substitution
'
166
:errorp errorp))
'
167
'
168
(%set-documentation
'
169
(match matchf)
'
170
"Sets up a lexical environment to evaluate FORMS after an unification.
2009-04-15 mantoniotti
171
2010-02-05 pix
172
MATCH and MATCHF unify a TEMPLATE and an OBJECT and then set up a lexical
2009-04-15 mantoniotti
173
environment where the variables present in the template are bound
10:16:24 '
174
lexically. Note that both variable names '?FOO' and 'FOO' are bound
'
175
for convenience.
'
176
'
177
MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will
'
178
generate a template at read-time).
'
179
2010-02-05 pix
180
MATCH and MATCHF forms return the values returned by the evaluation of the
2009-04-15 mantoniotti
181
last of the FORMS.
10:16:24 '
182
'
183
If ERRORP is non-NIL (the default) then the form raises a
'
184
UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
'
185
whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
2010-02-05 pix
186
raising from the evaluation of FORMS will /not/ be caught and handled
2009-04-15 mantoniotti
187
according to ERRORP settings.)
10:16:24 '
188
2010-02-05 pix
189
A surrounding BLOCK named NAMED is set up around the matching code.")
2004-11-17 mantoniotti
190
22:19:54 '
191
'
192
'
193
(define-condition unification-non-exhaustive (unification-failure)
2010-02-04 pix
194
()
07:32:18 '
195
(:default-initargs
'
196
:format-control "Non exhaustive matching."))
'
197
2004-11-17 mantoniotti
198
2010-02-04 pix
199
(defmacro match-cond (&body clauses)
07:32:18 '
200
(%match-expander 'match 'cond clauses))
'
201
'
202
(defmacro matchf-cond (&body clauses)
'
203
(%match-expander 'matchf 'cond clauses))
2004-11-17 mantoniotti
204
22:19:54 '
205
(defmacro matching ((&key errorp
2010-02-04 pix
206
default-substitution
07:32:18 '
207
(named nil)
'
208
(matching-named nil matching-named-p))
2010-01-15 pix
209
&body match-clauses)
2010-02-04 pix
210
(when matching-named-p
07:32:18 '
211
(warn ":matching-named is deprecated. Use :named instead."))
'
212
(%match-expander 'match 'cond match-clauses
'
213
:errorp errorp
'
214
:error-form `(error 'unification-non-exhaustive)
'
215
:named (or named matching-named)
'
216
:environment default-substitution))
2004-11-17 mantoniotti
217
2010-02-05 pix
218
(%set-documentation
03:21:40 '
219
(match-cond matchf-cond matching)
'
220
"MATCH-COND, MATCHF-COND, and MATCHING set up a COND-like environment for
'
221
multiple template matching clauses.
2005-04-27 mantoniotti
222
2010-02-05 pix
223
Their syntax comprises a number of clauses of the form
2005-04-27 mantoniotti
224
<clause> ::= <regular-clause> | <default-clause>
2010-02-05 pix
225
<regular-clause> ::= ((<template> <form>) &body <forms>)
2005-04-27 mantoniotti
226
<default-clause> ::= (t &body <forms>)
20:41:56 '
227
| (otherwise &body <forms>)
'
228
<form> and <forms> are regular Common Lisp forms.
'
229
<template> is a unification template.
'
230
2010-02-05 pix
231
The full syntax is
03:21:40 '
232
match-cond <clauses>
'
233
matchf-cond <clauses>
'
234
matching (&key errorp default-substitution named) <clauses>
2005-04-27 mantoniotti
235
20:41:56 '
236
Each clause evaluates its forms in an environment where the variables
'
237
present in the template are bound lexically. Note that both variable
'
238
names '?FOO' and 'FOO' are bound for convenience.
'
239
2010-02-05 pix
240
The values returned by the macros are those of the last form in
2005-04-27 mantoniotti
241
the first clause that satisfies the match test.
20:41:56 '
242
'
243
If ERRORP is non-NIL then if none of the regular clauses matches, then
'
244
an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
'
245
any default clause. Otherwise, the default clause behaves as a
2010-02-05 pix
246
standard COND default clause. The default value of ERRORP is NIL.
03:21:40 '
247
")
'
248
'
249
'
250
(defmacro match-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))
'
251
&body clauses)
2010-02-04 pix
252
(when match-case-named-p
07:32:18 '
253
(warn ":match-case-named is deprecated. Use :named instead."))
'
254
(%match-expander 'match 'case clauses
'
255
:named (or named match-case-named)
'
256
:environment default-substitution
'
257
:errorp errorp
'
258
:error-form `(error 'unification-non-exhaustive)
'
259
:keyform object))
2005-04-27 mantoniotti
260
2010-02-04 pix
261
(defmacro match-ecase ((object &key default-substitution named)
07:32:18 '
262
&body clauses)
'
263
(%match-expander 'match 'case clauses
'
264
:named named
'
265
:environment default-substitution
'
266
:default `(error 'unification-non-exhaustive)
'
267
:keyform object))
2009-12-17 mantoniotti
268
2010-02-04 pix
269
(defmacro matchf-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))
07:32:18 '
270
&body clauses)
'
271
(when match-case-named-p
'
272
(warn ":match-case-named is deprecated. Use :named instead."))
'
273
(%match-expander 'matchf 'case clauses
'
274
:named (or named match-case-named)
'
275
:environment default-substitution
'
276
:errorp errorp
'
277
:error-form `(error 'unification-non-exhaustive)
'
278
:keyform object))
'
279
'
280
(defmacro matchf-ecase ((object &key default-substitution named)
'
281
&body clauses)
'
282
(%match-expander 'matchf 'case clauses
'
283
:named named
'
284
:environment default-substitution
'
285
:default `(error 'unification-non-exhaustive)
'
286
:keyform object))
'
287
2010-02-05 pix
288
(%set-documentation
03:21:40 '
289
(match-case match-ecase matchf-case matchf-ecase)
'
290
"MATCH-CASE, MATCH-ECASE, MATCHF-CASE, and MATCHF-ECASE set up a CASE-like
'
291
environment for multiple template matching clauses.
'
292
'
293
Their syntax comprises a number of clauses of the form
'
294
<clause> ::= <regular-clause> | <default-clause>
'
295
<regular-clause> ::= (<template> &body <forms>)
'
296
<default-clause> ::= (t &body <forms>)
'
297
| (otherwise &body <forms>)
'
298
<form> and <forms> are regular Common Lisp forms.
'
299
<template> is a unification template.
'
300
'
301
The full syntax is
'
302
match-case (<object> &key default-substitution named errorp) <clauses>
'
303
match-ecase (<object> &key default-substitution named) <clauses>
'
304
matchf-case (<object> &key default-substitution named errorp) <clauses>
'
305
matchf-ecase (<object> &key default-substitution named) <clauses>
'
306
'
307
Each clause evaluates its forms in an environment where the variables
'
308
present in the template are bound lexically. Note that both variable
'
309
names '?FOO' and 'FOO' are bound for convenience.
'
310
'
311
The values returned by the macros are those of the last form in
'
312
the first clause that satisfies the match test.
'
313
'
314
MATCHF-ECASE and MATCHF-CASE behave like MATCH-ECASE and MATCH-CASE, but the
'
315
patterns are not evaluated (i.e., they rely on MATCHF instead of MATCH to
'
316
construct the macro expansion).
'
317
")
'
318
2009-12-17 mantoniotti
319
2007-11-09 mantoniotti
320
;;;;---------------------------------------------------------------------------
13:43:20 '
321
;;;; Testing.
'
322
'
323
#| Tests
'
324
'
325
(let ((n 42))
'
326
(matching ()
'
327
((0 n) 1)
'
328
((?x n) (* x (1- x)))))
'
329
'
330
'
331
(let ((n 42))
'
332
(match-case (n)
'
333
(0 1)
'
334
(?x (* x (1- x)))))
'
335
'
336
'
337
(let ((n 42))
'
338
(match-case (n)
'
339
(0 1)
'
340
(otherwise (* n (1- n)))))
'
341
'
342
(defun fatt (x)
'
343
(match-case (x :errorp t)
'
344
(0 1)
'
345
(#T(number ?n) (* ?n (fatt (1- n))))
'
346
))
'
347
'
348
|#
2005-04-27 mantoniotti
349
2007-11-09 mantoniotti
350
;;;; end of file -- math-blocks.lisp --