repos
/
cl-unification
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Rather than a new UNIFY** function, make UNIFY* work that way
Annotate for file unifier.lisp
2004-11-17 mantoniotti
1
;;; -*- Mode: Lisp -*-
22:19:54 '
2
'
3
;;; unifier.lisp
'
4
;;; General CL structures unifier.
'
5
'
6
(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
'
7
2009-04-15 mantoniotti
8
(defgeneric unify (a b &optional env &key &allow-other-keys)
2004-11-17 mantoniotti
9
(:documentation
22:19:54 '
10
"Unifies two objects A and B given a substitution ENV.
'
11
A is a Common Lisp object and B is either a Common Lisp object or a
'
12
\"template\", A and B can be commuted.
'
13
'
14
The unification rules are rather complex. Each method of the generic
'
15
function implements a specific rule of unification.
'
16
'
17
The generic function returns a `substitution' upon success or it
'
18
signals a UNIFICATION-FAILURE condition upon failure."))
'
19
'
20
'
21
'
22
;;;===========================================================================
'
23
;;; Simple, non template methods.
'
24
2009-04-15 mantoniotti
25
(defmethod unify ((a symbol) (b list)
10:14:24 '
26
&optional (env (make-empty-environment))
'
27
&key &allow-other-keys)
2004-11-17 mantoniotti
28
"Unifies a symbol A and a list B in an environment ENV.
22:19:54 '
29
If A is not a variable then an error of type UNIFICATION-FAILURE is
'
30
signaled. If A is a unification variable, then the environment ENV is
'
31
extended with a binding for A to B, unless the occurrence check is
'
32
called and fails, in which case an error is signaled."
'
33
(cond ((variable-any-p a) env)
'
34
((variablep a) (var-unify a b env))
'
35
(t (error 'unification-failure
'
36
:format-control "Cannot unify a symbol with a list: ~S ~S."
'
37
:format-arguments (list a b)))))
'
38
'
39
2009-04-15 mantoniotti
40
(defmethod unify ((b list) (a symbol)
10:14:24 '
41
&optional (env (make-empty-environment))
'
42
&key &allow-other-keys)
2004-11-17 mantoniotti
43
"Unifies a symbol B and a list A in an environment ENV.
22:19:54 '
44
If A is not a variable then an error of type UNIFICATION-FAILURE is
'
45
signaled. If A is a unification variable, then the environment ENV is
'
46
extended with a binding for A to B, unless the occurrence check is
'
47
called and fails, in which case an error is signaled."
'
48
(cond ((variable-any-p a) env)
'
49
((variablep a) (var-unify a b env))
'
50
(t (error 'unification-failure
'
51
:format-control "Cannot unify a list with a symbol: ~S ~S."
'
52
:format-arguments (list b a)))))
'
53
'
54
2009-04-15 mantoniotti
55
(defmethod unify ((a list) (b list)
10:14:24 '
56
&optional (env (make-empty-environment))
'
57
&key &allow-other-keys)
2004-11-17 mantoniotti
58
"Unifies a list A and a list B in an environment ENV.
22:19:54 '
59
The unification procedure proceedes recursively on each element of
'
60
both lists. If two elements cannot be unified then an error of type
'
61
UNIFICATION-FAILURE is signaled. Otherwise a possibly extended
'
62
environment is returned."
'
63
(unify (rest a) (rest b) (unify (first a) (first b) env)))
'
64
'
65
'
66
2009-04-15 mantoniotti
67
(defmethod unify ((a number) (b number)
10:14:24 '
68
&optional (env (make-empty-environment))
'
69
&key &allow-other-keys)
2004-11-17 mantoniotti
70
"Unifies two numbers A and B.
22:19:54 '
71
Two numbers unify only if and only if they are equal as per the function #'=, in
'
72
which case an unmodified envirironment ENV is returned.
'
73
Otherwise an error of type UNIFICATION-FAILURE is signalled.
'
74
Of course, asking for unification of two floating point numbers may
'
75
not yield the expected result."
'
76
(if (= a b)
'
77
env
'
78
(error 'unification-failure
'
79
:format-control "Cannot unify two different numbers: ~S ~S."
'
80
:format-arguments (list a b))))
'
81
'
82
2009-04-15 mantoniotti
83
(defparameter *unify-string-case-sensitive-p* t)
2004-11-17 mantoniotti
84
2009-04-15 mantoniotti
85
(defmethod unify ((a character) (b character)
10:14:24 '
86
&optional (env (make-empty-environment))
'
87
&key
'
88
(case-sensitive *unify-string-case-sensitive-p*)
'
89
&allow-other-keys)
'
90
"Unifies two strings A and B.
'
91
Two CHARACTERs A and B unify if and only if they satisfy either #'CHAR= or
'
92
#'CHAR-EQUAL. The choice of which of test to perform (#'CHAR= or #'CHAR-EQUAL)
'
93
is made according to the value of the variable
2011-04-02 rbrown
94
*UNIFY-STRING-CASE-INSENSITIVE-P*, which defaults to NIL.
2009-04-15 mantoniotti
95
If A and B unify then an unmodified environment ENV is returned,
10:14:24 '
96
otherwise an error of type UNIFICATION-FAILURE is signaled."
'
97
(cond ((and case-sensitive (char= a b))
'
98
env)
2010-01-20 pix
99
((and (not case-sensitive) (char-equal a b))
2009-04-15 mantoniotti
100
env)
10:14:24 '
101
(t
'
102
(error 'unification-failure
2010-01-20 pix
103
:format-control "Cannot unify two different characters: ~S ~S."
2009-04-15 mantoniotti
104
:format-arguments (list a b)))))
10:14:24 '
105
'
106
'
107
(defmethod unify ((a string) (b string)
'
108
&optional (env (make-empty-environment))
'
109
&key
'
110
(case-sensitive *unify-string-case-sensitive-p*)
'
111
&allow-other-keys)
2004-11-17 mantoniotti
112
"Unifies two strings A and B.
22:19:54 '
113
Two strings A and B unify if and only if they satisfy either #'STRING= or
'
114
#'STRING-EQUAL. The choice of which of test to perform (#'STRING= or #'STRING-EQUAL)
'
115
is made according to the value of the variable
2011-04-02 rbrown
116
*UNIFY-STRING-CASE-INSENSITIVE-P*, which defaults to NIL.
2004-11-17 mantoniotti
117
If A and B unify then an unmodified environment ENV is returned,
22:19:54 '
118
otherwise an error of type UNIFICATION-FAILURE is signaled."
2009-04-15 mantoniotti
119
(cond ((and case-sensitive (string= a b))
2004-11-17 mantoniotti
120
env)
2010-01-20 pix
121
((and (not case-sensitive) (string-equal a b))
2004-11-17 mantoniotti
122
env)
22:19:54 '
123
(t
'
124
(error 'unification-failure
2010-01-20 pix
125
:format-control "Cannot unify two different strings: ~S ~S."
2004-11-17 mantoniotti
126
:format-arguments (list a b)))))
22:19:54 '
127
'
128
2009-04-15 mantoniotti
129
(defmethod unify ((a symbol) (b string)
10:14:24 '
130
&optional (env (make-empty-environment))
'
131
&key &allow-other-keys)
2004-11-17 mantoniotti
132
(cond ((variable-any-p a) env)
2005-05-20 mantoniotti
133
((variablep a) (var-unify a b env))
2004-11-17 mantoniotti
134
(t (error 'unification-failure
2005-05-20 mantoniotti
135
:format-control "Cannot unify a symbol with a string: ~S ~S."
15:19:53 '
136
:format-arguments (list a b)))))
2004-11-17 mantoniotti
137
22:19:54 '
138
2009-04-15 mantoniotti
139
(defmethod unify ((b string) (a symbol)
10:14:24 '
140
&optional (env (make-empty-environment))
'
141
&key &allow-other-keys)
2004-11-17 mantoniotti
142
(cond ((variable-any-p a) env)
2005-05-20 mantoniotti
143
((variablep a) (var-unify a b env))
2004-11-17 mantoniotti
144
(t (error 'unification-failure
22:19:54 '
145
:format-control "Cannot unify a string with a symbol: ~S ~S."
'
146
:format-arguments (list b a)))))
'
147
'
148
2009-04-15 mantoniotti
149
(defmethod unify ((a symbol) (b symbol)
10:14:24 '
150
&optional (env (make-empty-environment))
'
151
&key &allow-other-keys)
2004-11-17 mantoniotti
152
(cond ((variable-any-p a) env)
22:19:54 '
153
((variablep a) (var-unify a b env))
'
154
((variable-any-p b) env)
'
155
((variablep b) (var-unify b a env))
'
156
((eq a b) env)
'
157
(t (error 'unification-failure
'
158
:format-control "Cannot unify two different symbols: ~S ~S."
'
159
:format-arguments (list a b)))))
'
160
'
161
2009-04-15 mantoniotti
162
(defmethod unify ((a symbol) (b t)
10:14:24 '
163
&optional (env (make-empty-environment))
'
164
&key &allow-other-keys)
2004-11-17 mantoniotti
165
(cond ((variable-any-p a) env)
2005-05-20 mantoniotti
166
((variablep a) (var-unify a b env))
2004-11-17 mantoniotti
167
(t (call-next-method))))
22:19:54 '
168
'
169
2009-04-15 mantoniotti
170
(defmethod unify ((b t) (a symbol)
10:14:24 '
171
&optional (env (make-empty-environment))
'
172
&key &allow-other-keys)
2004-11-17 mantoniotti
173
(cond ((variable-any-p a) env)
2005-05-20 mantoniotti
174
((variablep a) (var-unify a b env))
2004-11-17 mantoniotti
175
(t (call-next-method))))
22:19:54 '
176
'
177
2009-04-15 mantoniotti
178
(defmethod unify ((a symbol) (b array)
10:14:24 '
179
&optional (env (make-empty-environment))
'
180
&key &allow-other-keys)
2004-11-17 mantoniotti
181
(cond ((variable-any-p a) env)
22:19:54 '
182
((variablep a) (var-unify a b env))
'
183
(t (error 'unification-failure
2009-04-15 mantoniotti
184
:format-control "Cannot unify a symbol with ~
10:14:24 '
185
an array or vector: ~S and ~S."
2004-11-17 mantoniotti
186
:format-arguments (list a b)))))
22:19:54 '
187
'
188
2009-04-15 mantoniotti
189
(defmethod unify ((b array) (a symbol)
10:14:24 '
190
&optional (env (make-empty-environment))
'
191
&key &allow-other-keys)
2004-11-17 mantoniotti
192
(cond ((variable-any-p a) env)
22:19:54 '
193
((variablep a) (var-unify a b env))
'
194
(t (error 'unification-failure
'
195
:format-control "Cannot unify an array or vector with a symbol: ~S and ~S."
'
196
:format-arguments (list a b)))))
'
197
'
198
2009-04-15 mantoniotti
199
(defmethod unify ((as vector) (bs vector)
10:14:24 '
200
&optional (env (make-empty-environment))
'
201
&key &allow-other-keys)
2004-11-17 mantoniotti
202
(unless (= (length as) (length bs))
22:19:54 '
203
(error 'unification-failure
'
204
:format-control "Cannot unify two vectors of different length: ~D and ~D."
'
205
:format-arguments (list (length as) (length bs))))
'
206
(loop for a across as
'
207
for b across bs
'
208
for mgu = (unify a b env) then (unify a b mgu)
'
209
finally (return mgu)))
'
210
'
211
2009-04-15 mantoniotti
212
(defmethod unify ((s1 sequence) (s2 sequence)
10:14:24 '
213
&optional (env (make-empty-environment))
'
214
&key &allow-other-keys)
2004-11-17 mantoniotti
215
(unless (= (length s1) (length s2))
22:19:54 '
216
(error 'unification-failure
'
217
:format-control "Cannot unify two sequences of different length: ~D and ~D."
'
218
:format-arguments (list (length s1) (length s2))))
'
219
(loop for i from 0 below (length s1)
'
220
for j from 0 below (length s2)
'
221
for mgu = (unify (elt s1 i) (elt s2 j) env) then (unify (elt s1 i) (elt s2 j) mgu)
'
222
finally (return mgu)))
'
223
'
224
'
225
'
226
(defgeneric untyped-unify (a b &optional env))
'
227
2009-12-17 mantoniotti
228
(defmethod untyped-unify ((as list) (bs vector)
16:44:46 '
229
&optional (env (make-empty-environment)))
2004-11-17 mantoniotti
230
(loop for a in as
22:19:54 '
231
for b across bs
'
232
for mgu = (unify a b env) then (unify a b mgu)
'
233
finally (return mgu)))
'
234
'
235
2009-12-17 mantoniotti
236
(defmethod untyped-unify ((as vector) (bs list)
16:44:46 '
237
&optional (env (make-empty-environment)))
2004-11-17 mantoniotti
238
(untyped-unify bs as env))
22:19:54 '
239
'
240
(defmethod untyped-unify ((a t) (b t) &optional (env (make-empty-environment)))
'
241
(unify a b env))
'
242
'
243
2009-04-15 mantoniotti
244
(defmethod unify ((as array) (bs array)
10:14:24 '
245
&optional (env (make-empty-environment))
'
246
&key &allow-other-keys)
2004-11-17 mantoniotti
247
(unless (= (array-total-size as) (array-total-size bs))
22:19:54 '
248
(error 'unification-failure
'
249
:format-control "Cannot unify two arrays of different total size: ~D and ~D."
'
250
:format-arguments (list (array-total-size as) (array-total-size bs))))
'
251
(loop for ai from 0 below (array-total-size as)
'
252
for bi from 0 below (array-total-size bs)
'
253
for mgu = (unify (row-major-aref as ai) (row-major-aref bs bi) env)
'
254
then (unify (row-major-aref as ai) (row-major-aref bs bi) mgu)
'
255
finally (return mgu)))
'
256
'
257
'
258
;;; Catch all method.
'
259
2009-04-15 mantoniotti
260
(defmethod unify ((a t) (b t)
10:14:24 '
261
&optional (env (make-empty-environment))
'
262
&key &allow-other-keys)
2004-11-17 mantoniotti
263
(if (equalp a b)
22:19:54 '
264
env
'
265
(error 'unification-failure
'
266
:format-control "Cannot unify a ~S and a ~S: ~S ~S."
'
267
:format-arguments (list (type-of a) (type-of b) a b))))
'
268
'
269
'
270
;;;===========================================================================
'
271
;;; Templates methods.
'
272
'
273
'
274
;;; valid-template-p --
'
275
;;; Useful later. Tests whether the object X can be considered a template.
2005-01-28 mantoniotti
276
;;; This should probably become a generic function.
2004-11-17 mantoniotti
277
22:19:54 '
278
(defun valid-template-p (x)
'
279
(or (symbolp x)
'
280
(consp x)
'
281
(numberp x)
2005-01-28 mantoniotti
282
(arrayp x)
19:30:35 '
283
(typep (class-of x) 'structure-class)
'
284
(typep (class-of x) 'standard-class)
'
285
(typep (class-of x) 'built-in-class)
2004-11-17 mantoniotti
286
(template-p x)))
22:19:54 '
287
'
288
'
289
;;; Special catch all method.
'
290
2009-04-15 mantoniotti
291
(defmethod unify ((x template) (y template)
10:14:24 '
292
&optional (env)
'
293
&key &allow-other-keys)
2006-07-19 mantoniotti
294
(declare (ignore env))
2004-11-17 mantoniotti
295
(error 'unification-failure
2009-04-15 mantoniotti
296
:format-control "Unification of two templates of type ~A and ~A ~
10:14:24 '
297
has not been yet implemented."
2004-11-17 mantoniotti
298
:format-arguments (list (class-name (class-of x))
22:19:54 '
299
(class-name (class-of y)))))
'
300
'
301
'
302
;;;---------------------------------------------------------------------------
'
303
;;; NIL special unification methods.
'
304
2006-07-19 mantoniotti
305
(defmethod unify ((x null) (y null)
2009-04-15 mantoniotti
306
&optional (env (make-empty-environment))
10:14:24 '
307
&key &allow-other-keys)
2006-07-19 mantoniotti
308
env)
21:52:34 '
309
'
310
'
311
(defmethod unify ((x null) (nt nil-template)
2009-04-15 mantoniotti
312
&optional (env (make-empty-environment))
10:14:24 '
313
&key &allow-other-keys)
2004-11-17 mantoniotti
314
env)
22:19:54 '
315
'
316
2006-07-19 mantoniotti
317
(defmethod unify ((nt nil-template) (x null)
2009-04-15 mantoniotti
318
&optional (env (make-empty-environment))
10:14:24 '
319
&key &allow-other-keys)
2004-11-17 mantoniotti
320
env)
22:19:54 '
321
'
322
2006-07-19 mantoniotti
323
(defmethod unify ((nt1 nil-template) (nt2 nil-template)
2009-04-15 mantoniotti
324
&optional (env (make-empty-environment))
10:14:24 '
325
&key &allow-other-keys)
2004-11-17 mantoniotti
326
env)
22:19:54 '
327
'
328
'
329
;;;---------------------------------------------------------------------------
'
330
;;; Symbol methods.
'
331
2009-04-15 mantoniotti
332
(defmethod unify ((a symbol) (b symbol-template)
10:14:24 '
333
&optional (env (make-empty-environment))
'
334
&key &allow-other-keys)
2004-11-17 mantoniotti
335
(cond ((variable-any-p a) env)
22:19:54 '
336
((variablep a) (var-unify a b env))
'
337
(t (unify a (symbol-template-symbol b) env))))
'
338
'
339
2009-04-15 mantoniotti
340
(defmethod unify ((b symbol-template) (a symbol)
10:14:24 '
341
&optional (env (make-empty-environment))
'
342
&key &allow-other-keys)
2004-11-17 mantoniotti
343
(unify a b env))
22:19:54 '
344
'
345
2009-04-15 mantoniotti
346
(defmethod unify ((a symbol) (b template)
10:14:24 '
347
&optional (env)
'
348
&key &allow-other-keys)
2004-11-17 mantoniotti
349
(declare (ignore env))
22:19:54 '
350
(error 'unification-failure
'
351
:format-control "Cannot unify symbol ~S with template ~S."
'
352
:format-arguments (list a b)))
'
353
2009-04-15 mantoniotti
354
10:14:24 '
355
(defmethod unify ((b template) (a symbol)
'
356
&optional (env (make-empty-environment))
'
357
&key &allow-other-keys)
2004-11-17 mantoniotti
358
(unify a b env))
22:19:54 '
359
'
360
'
361
'
362
;;;---------------------------------------------------------------------------
'
363
;;; Number template methods.
'
364
2009-04-15 mantoniotti
365
(defmethod unify ((a number) (b number-template)
10:14:24 '
366
&optional (env (make-empty-environment))
'
367
&key &allow-other-keys)
2004-11-17 mantoniotti
368
(unify a (number-template-number b) env))
22:19:54 '
369
'
370
2009-04-15 mantoniotti
371
(defmethod unify ((b number-template) (a number)
10:14:24 '
372
&optional (env (make-empty-environment))
'
373
&key &allow-other-keys)
2004-11-17 mantoniotti
374
(unify a b env))
22:19:54 '
375
2009-04-15 mantoniotti
376
(defmethod unify ((a number) (b template)
10:14:24 '
377
&optional (env)
'
378
&key &allow-other-keys)
2004-11-17 mantoniotti
379
(declare (ignore env))
22:19:54 '
380
(error 'unification-failure
'
381
:format-control "Cannot unify the number ~S with template ~S."
'
382
:format-arguments (list a b)))
'
383
2009-04-15 mantoniotti
384
(defmethod unify ((b template) (a number)
10:14:24 '
385
&optional (env (make-empty-environment))
'
386
&key &allow-other-keys)
2004-11-17 mantoniotti
387
(unify a b env))
22:19:54 '
388
'
389
'
390
;;;---------------------------------------------------------------------------
'
391
;;; Sequence (List) template methods
'
392
2009-04-15 mantoniotti
393
(defmethod unify ((a sequence) (b template)
10:14:24 '
394
&optional (env)
'
395
&key &allow-other-keys)
2006-07-19 mantoniotti
396
(declare (ignore env))
2004-11-17 mantoniotti
397
(error 'unification-failure
2009-04-15 mantoniotti
398
:format-control "Cannot unify a sequence with a non sequence ~
10:14:24 '
399
or non sequence access template: ~S and ~S."
2004-11-17 mantoniotti
400
:format-arguments (list a b)))
22:19:54 '
401
'
402
2009-04-15 mantoniotti
403
(defmethod unify ((b template) (a sequence)
10:14:24 '
404
&optional (env (make-empty-environment))
'
405
&key &allow-other-keys)
2004-11-17 mantoniotti
406
(unify a b env))
22:19:54 '
407
'
408
2009-04-15 mantoniotti
409
#| Needs to be fixed.
10:14:24 '
410
(defmethod unify ((a list) (b lambda-template) &optional (env (make-empty-environment)))
'
411
(unify a (template-spec b) env))
'
412
'
413
'
414
(defmethod unify ((b lambda-template) (a list) &optional (env (make-empty-environment)))
'
415
(unify (template-spec b) a env))
'
416
|#
'
417
'
418
2004-11-17 mantoniotti
419
;;; The next is incomplete and does not signal appropriate errors.
22:19:54 '
420
2009-04-15 mantoniotti
421
(defmethod unify ((a list) (b template)
10:14:24 '
422
&optional (env)
'
423
&key &allow-other-keys)
2004-11-17 mantoniotti
424
(declare (ignore env))
22:19:54 '
425
(error 'unification-failure
'
426
:format-control "Cannot unify a list with a non-list template: ~S ~S."
'
427
:format-arguments (list a b)))
'
428
'
429
2009-04-15 mantoniotti
430
(defmethod unify ((a list) (b sequence-template)
10:14:24 '
431
&optional (env (make-empty-environment))
'
432
&key &allow-other-keys)
2004-11-17 mantoniotti
433
(let ((template-lambda-list (sequence-template-lambda-list b))
22:19:54 '
434
(ll (list-length a))
'
435
)
'
436
(multiple-value-bind (vars optionals keys rest)
'
437
(parse-extended-ordinary-lambda-list template-lambda-list
'
438
:ordinary-variable-test #'valid-template-p
'
439
:optional-variable-test #'valid-template-p
'
440
:key-variable-test #'valid-template-p
'
441
:rest-variable-test #'valid-template-p
'
442
)
2011-04-02 rbrown
443
2004-11-17 mantoniotti
444
(let* ((n-vars (list-length vars))
22:19:54 '
445
(n-optionals (list-length optionals))
2005-10-25 mantoniotti
446
(env (unify (subseq a 0 (min ll (list-length vars)))
19:17:33 '
447
vars
'
448
env))
2004-11-17 mantoniotti
449
)
22:19:54 '
450
(when (and optionals (>= ll (+ n-vars n-optionals)))
'
451
(setf env (unify (subseq a n-vars (+ n-vars n-optionals)) optionals env)))
'
452
(when (and rest (>= ll (+ n-vars n-optionals)))
'
453
(setf env (unify (subseq a (+ n-vars n-optionals)) (first rest) env)))
2009-12-17 mantoniotti
454
(when keys (warn "Sorry matching of keywords ~S not yet implemented." keys))
2004-11-17 mantoniotti
455
env
22:19:54 '
456
))))
'
457
'
458
'
459
2009-04-15 mantoniotti
460
(defmethod unify ((b template) (a list)
10:14:24 '
461
&optional (env (make-empty-environment))
'
462
&key &allow-other-keys)
2004-11-17 mantoniotti
463
(unify a b env))
22:19:54 '
464
'
465
'
466
'
467
;;;---------------------------------------------------------------------------
'
468
;;; Vector template methods.
'
469
2009-04-15 mantoniotti
470
(defmethod unify ((a vector) (b template)
10:14:24 '
471
&optional (env)
'
472
&key &allow-other-keys)
2006-07-19 mantoniotti
473
(declare (ignore env))
2004-11-17 mantoniotti
474
(error 'unification-failure
22:19:54 '
475
:format-control "Cannot unify a vector with a non-vector template: ~S ~S."
'
476
:format-arguments (list a b)))
'
477
'
478
2011-04-02 rbrown
479
(defmethod unify ((a vector) (b vector-template)
2009-04-15 mantoniotti
480
&optional (env (make-empty-environment))
10:14:24 '
481
&key &allow-other-keys)
2004-11-17 mantoniotti
482
(let ((template-lambda-list (sequence-template-lambda-list b))
22:19:54 '
483
(vl (length a))
'
484
)
'
485
(multiple-value-bind (vars optionals keys rest)
'
486
(parse-extended-ordinary-lambda-list template-lambda-list
'
487
:ordinary-variable-test #'valid-template-p
'
488
:optional-variable-test #'valid-template-p
'
489
:key-variable-test #'valid-template-p
'
490
:rest-variable-test #'valid-template-p
'
491
)
2011-04-02 rbrown
492
2004-11-17 mantoniotti
493
(let ((n-vars (list-length vars))
22:19:54 '
494
(n-optionals (list-length optionals))
'
495
)
'
496
(loop for v in vars
'
497
for e across (subseq a 0 (list-length vars))
'
498
for mgu = (unify v e env) then (unify v e mgu)
'
499
finally (setf env mgu))
'
500
(when (and optionals (>= vl (+ n-vars n-optionals)))
'
501
(loop for v in optionals
'
502
for e across (subseq a n-vars (+ n-vars n-optionals))
'
503
for mgu = (unify v e env) then (unify v e mgu)
'
504
finally (setf env mgu)))
'
505
(when (and rest (>= vl (+ n-vars n-optionals)))
'
506
(setf env (unify (subseq a (+ n-vars n-optionals)) (first rest) env)))
'
507
(when keys (warn "Sorry matching of keywords ~S not yet implemented." keys))
'
508
env
'
509
))))
'
510
'
511
2009-04-15 mantoniotti
512
(defmethod unify ((b template) (a vector)
10:14:24 '
513
&optional (env (make-empty-environment))
'
514
&key &allow-other-keys)
2004-11-17 mantoniotti
515
(unify a b env))
22:19:54 '
516
'
517
'
518
;;;---------------------------------------------------------------------------
'
519
;;; Array template methods.
'
520
2009-04-15 mantoniotti
521
(defmethod unify ((a array) (b template)
10:14:24 '
522
&optional (env)
'
523
&key &allow-other-keys)
2006-07-19 mantoniotti
524
(declare (ignore env))
2004-11-17 mantoniotti
525
(error 'unification-failure
2009-04-15 mantoniotti
526
:format-control "Cannot unify an array with a non array ~
10:14:24 '
527
or non array access template: ~S and ~S."
2004-11-17 mantoniotti
528
:format-arguments (list a b)))
22:19:54 '
529
2009-04-15 mantoniotti
530
(defmethod unify ((b template) (a array)
10:14:24 '
531
&optional (env (make-empty-environment))
'
532
&key &allow-other-keys)
2004-11-17 mantoniotti
533
(unify a b env))
22:19:54 '
534
'
535
'
536
(defun unify-array-row (array dims shape-template indexes env)
'
537
(cond ((null dims) env)
'
538
((= (list-length dims) 1)
'
539
;; Unify the row with the shape-template.
'
540
(let ((row (make-array (first dims)
'
541
:displaced-to array
'
542
:displaced-index-offset
2009-04-15 mantoniotti
543
(apply #'array-row-major-index
10:14:24 '
544
array
'
545
(append indexes (list 0))))))
2004-11-17 mantoniotti
546
(declare (dynamic-extent row)
22:19:54 '
547
(type array row))
'
548
(untyped-unify row shape-template env)))
'
549
(t
'
550
(loop for i from 0 below (first dims)
'
551
for row-template in shape-template
'
552
do (unify-array-row array
'
553
(rest dims)
'
554
row-template
'
555
(append indexes (list i))
'
556
env)
'
557
finally (return env)))
'
558
))
'
559
'
560
'
561
(defun unify-array-rows (array shape-template env)
'
562
(unify-array-row array (array-dimensions array) shape-template () env))
'
563
'
564
2009-04-15 mantoniotti
565
(defmethod unify ((a array) (b array-template)
10:14:24 '
566
&optional (env (make-empty-environment))
'
567
&key &allow-other-keys)
2004-11-17 mantoniotti
568
(let ((template-spec (template-spec b)))
22:19:54 '
569
(if (= 2 (length template-spec))
'
570
'
571
;; Template is (<array type specifier> <shape-template>)
'
572
(destructuring-bind (array-type-spec shape-template)
'
573
template-spec
'
574
(declare (ignore array-type-spec))
'
575
;; Missing check for type-spec.
'
576
(unify-array-rows a shape-template env))
'
577
'
578
;; Template is (array (['*' | <element type>] [<dimension spec>]) <shape template>)
'
579
(destructuring-bind (array-kwd type-spec shape-template)
'
580
template-spec
2006-07-19 mantoniotti
581
(declare (ignore array-kwd type-spec))
2004-11-17 mantoniotti
582
;; Missing check for type-spec.
22:19:54 '
583
(unify-array-rows a shape-template env))
'
584
)))
'
585
'
586
'
587
'
588
;;;---------------------------------------------------------------------------
'
589
;;; Standard object template methods.
'
590
2009-04-15 mantoniotti
591
(defmethod unify ((a standard-object) (b template)
10:14:24 '
592
&optional (env)
'
593
&key &allow-other-keys)
2006-07-19 mantoniotti
594
(declare (ignore env))
2004-11-17 mantoniotti
595
(error 'unification-failure
2009-04-15 mantoniotti
596
:format-control "Cannot unify a standard object with a ~
10:14:24 '
597
non standard object template: ~S and ~S."
2004-11-17 mantoniotti
598
:format-arguments (list a b)))
22:19:54 '
599
2006-07-19 mantoniotti
600
#|| Old version with heavy syntax
2004-11-17 mantoniotti
601
(defmethod unify ((a standard-object) (b standard-object-template)
22:19:54 '
602
&optional (env (make-empty-environment)))
'
603
(destructuring-bind (class &rest template-slot-specs)
'
604
(template-spec b)
'
605
(unless (typep a class)
'
606
(error 'unification-failure
'
607
:format-control "Cannot unify an instance of ~S with a template for class ~S."
'
608
:format-arguments (list (class-of a) class)))
'
609
(flet ((slot-spec-unify (accessor-spec reader value-template mgu)
'
610
(ecase accessor-spec
'
611
(slot-value
'
612
(unify (slot-value a reader) value-template mgu))
'
613
(slot-accessor
'
614
(unify (funcall reader a) value-template mgu))))
'
615
)
'
616
(if template-slot-specs
'
617
(loop for (accessor-spec reader value-template) in template-slot-specs
'
618
for mgu = (slot-spec-unify accessor-spec reader value-template env)
'
619
then (slot-spec-unify accessor-spec reader value-template mgu)
'
620
finally (return mgu))
'
621
env))))
2006-07-19 mantoniotti
622
||#
2004-11-17 mantoniotti
623
22:19:54 '
624
'
625
(defmethod unify ((a standard-object) (b standard-object-template)
2009-04-15 mantoniotti
626
&optional (env (make-empty-environment))
10:14:24 '
627
&key &allow-other-keys)
2004-11-17 mantoniotti
628
(destructuring-bind (class &rest template-slot-specs)
22:19:54 '
629
(template-spec b)
'
630
(unless (typep a class)
'
631
(error 'unification-failure
'
632
:format-control "Cannot unify an instance of ~S with a template for class ~S."
'
633
:format-arguments (list (class-of a) class)))
'
634
(flet ((slot-spec-unify (reader value-template mgu)
'
635
(etypecase reader
'
636
(list
'
637
(assert (eq (first reader) 'slot-value))
'
638
(unify (slot-value a (second reader)) value-template mgu))
'
639
((or function symbol)
'
640
(unify (funcall reader a) value-template mgu))))
'
641
)
'
642
(if template-slot-specs
'
643
(loop for (reader value-template) on template-slot-specs by #'cddr
'
644
for mgu = (slot-spec-unify reader value-template env)
'
645
then (slot-spec-unify reader value-template mgu)
'
646
finally (return mgu))
'
647
env))))
'
648
'
649
2009-04-15 mantoniotti
650
(defmethod unify ((b template) (a standard-object)
10:14:24 '
651
&optional (env (make-empty-environment))
'
652
&key &allow-other-keys)
2004-11-17 mantoniotti
653
(unify a b env))
22:19:54 '
654
'
655
'
656
;;;---------------------------------------------------------------------------
'
657
;;; Structure object template methods.
'
658
2009-04-15 mantoniotti
659
(defmethod unify ((a structure-object) (b template)
10:14:24 '
660
&optional (env)
'
661
&key &allow-other-keys)
2006-07-19 mantoniotti
662
(declare (ignore env))
2004-11-17 mantoniotti
663
(error 'unification-failure
2009-04-15 mantoniotti
664
:format-control "Cannot unify a structure object with ~
10:14:24 '
665
a non structure object template: ~S and ~S."
2004-11-17 mantoniotti
666
:format-arguments (list a b)))
22:19:54 '
667
'
668
'
669
(defmethod unify ((a structure-object) (b structure-object-template)
2009-04-15 mantoniotti
670
&optional (env (make-empty-environment))
10:14:24 '
671
&key &allow-other-keys)
2004-11-17 mantoniotti
672
(destructuring-bind (class &rest template-slot-specs)
22:19:54 '
673
(template-spec b)
'
674
(unless (typep a class)
'
675
(error 'unification-failure
2009-04-15 mantoniotti
676
:format-control "Cannot unify an instance of ~S with a ~
10:14:24 '
677
template for structure ~S."
2004-11-17 mantoniotti
678
:format-arguments (list (class-of a) class)))
22:19:54 '
679
(if template-slot-specs
'
680
(loop for (reader value-template) on template-slot-specs by #'cddr
'
681
for mgu = (unify (funcall reader a) value-template env)
'
682
then (unify (funcall reader a) value-template mgu)
'
683
finally (return mgu))
'
684
env)))
'
685
'
686
2009-04-15 mantoniotti
687
(defmethod unify ((b template) (a structure-object)
10:14:24 '
688
&optional (env (make-empty-environment))
'
689
&key &allow-other-keys)
2004-11-17 mantoniotti
690
(unify a b env))
22:19:54 '
691
'
692
'
693
;;;---------------------------------------------------------------------------
'
694
;;; Expression template SUBSEQ methods.
'
695
2009-04-15 mantoniotti
696
;;; SEQUENCE
10:14:24 '
697
;;; For non LIST and non VECTOR possible SEQUENCE types.
'
698
'
699
(defmethod unify ((a sequence) (b subseq-template)
'
700
&optional (env (make-empty-environment))
'
701
&key &allow-other-keys)
2004-11-17 mantoniotti
702
(destructuring-bind (subseq-kwd from to &rest spec)
22:19:54 '
703
(template-spec b)
2009-04-15 mantoniotti
704
(declare (ignore subseq-kwd))
2004-11-17 mantoniotti
705
(let* ((seq-type (type-of a))
2009-04-15 mantoniotti
706
(seq-template-kind (if (symbolp seq-type)
10:14:24 '
707
seq-type
'
708
(first seq-type))) ; Stupid FTTB.
2004-11-17 mantoniotti
709
)
2009-04-15 mantoniotti
710
(unify (subseq a from to)
10:14:24 '
711
(make-template seq-template-kind `(,seq-template-kind ,@spec))
'
712
env))))
'
713
'
714
'
715
;;; LIST
'
716
'
717
(defmethod unify ((a list) (b subseq-template)
'
718
&optional (env (make-empty-environment))
'
719
&key &allow-other-keys)
'
720
(destructuring-bind (subseq-kwd from to &rest spec)
'
721
(template-spec b)
'
722
(declare (ignore subseq-kwd))
2006-07-19 mantoniotti
723
(unify (subseq a from to)
2009-04-15 mantoniotti
724
(make-template 'list `(list ,@spec))
10:14:24 '
725
env)))
'
726
'
727
'
728
;;; VECTOR
'
729
'
730
(defmethod unify ((a vector) (b subseq-template)
'
731
&optional (env (make-empty-environment))
'
732
&key &allow-other-keys)
'
733
(destructuring-bind (subseq-kwd from to &rest spec)
'
734
(template-spec b)
'
735
(declare (ignore subseq-kwd))
'
736
(let ((seq-type (type-of a)))
'
737
(unify (subseq a from to)
'
738
(make-template seq-type `(,seq-type ,@spec))
'
739
env))))
2004-11-17 mantoniotti
740
22:19:54 '
741
2009-04-15 mantoniotti
742
(defmethod unify ((b subseq-template) (a sequence)
10:14:24 '
743
&optional (env (make-empty-environment))
'
744
&key &allow-other-keys)
2004-11-17 mantoniotti
745
(unify a b env))
22:19:54 '
746
'
747
'
748
;;;---------------------------------------------------------------------------
2009-04-15 mantoniotti
749
;;; Expression templates
2004-11-17 mantoniotti
750
2009-04-15 mantoniotti
751
;;; AREF methods.
10:14:24 '
752
'
753
(defmethod unify ((a array) (b aref-template)
'
754
&optional (env (make-empty-environment))
'
755
&key &allow-other-keys)
2004-11-17 mantoniotti
756
(destructuring-bind (aref-kwd indexes value-template)
22:19:54 '
757
(template-spec b)
'
758
(declare (ignore aref-kwd))
'
759
;; Missing check on index spec.
'
760
(unless (consp indexes)
'
761
(setf indexes (list indexes)))
'
762
(unify (apply #'aref a indexes) value-template env)))
'
763
'
764
2009-04-15 mantoniotti
765
;;; Necessary due to standard method sorting.
10:14:24 '
766
'
767
(defmethod unify ((a vector) (b aref-template)
'
768
&optional (env (make-empty-environment))
'
769
&key &allow-other-keys)
'
770
(destructuring-bind (aref-kwd indexes value-template)
'
771
(template-spec b)
'
772
(declare (ignore aref-kwd))
'
773
;; Missing check on index spec.
'
774
(when (and (consp indexes) (> (length indexes) 1))
'
775
(error 'unification-failure
'
776
:format-control "Cannot unify a vector with an element ~
'
777
too many dimensions down~@
'
778
(AREF #(...)~{ ~S~})."
'
779
:format-arguments (list indexes)
'
780
))
'
781
(unless (consp indexes)
'
782
(setf indexes (list indexes)))
'
783
(unify (apply #'aref a indexes) value-template env)))
'
784
'
785
'
786
(defmethod unify ((b aref-template) (a array)
'
787
&optional (env (make-empty-environment))
'
788
&key &allow-other-keys)
'
789
(unify a b env))
'
790
'
791
'
792
;;; ELT methods.
'
793
;;; LIST and VECTOR methods must be specified separatedly because of
'
794
;;; the UNIFY (VECTOR TEMPLATE) methods above. It is a snag, but a
'
795
;;; relatively small one. Besides, they are more efficient.
'
796
;;; The (SEQUENCE ELT-TEMPLATE) ELT-TEMPLATE method is left for those
'
797
;;; sequences which, according to the ANSI spec may exist and not be
'
798
;;; either VECTOR or LIST.
'
799
'
800
(defmethod unify ((a sequence) (b elt-template)
'
801
&optional (env (make-empty-environment))
'
802
&key &allow-other-keys)
'
803
(destructuring-bind (elt-kwd index value-template)
'
804
(template-spec b)
'
805
(declare (ignore elt-kwd)
'
806
(type fixnum index))
'
807
;; Missing index check.
'
808
(unify (elt a index) value-template env)))
'
809
'
810
'
811
(defmethod unify ((a vector) (b elt-template)
'
812
&optional (env (make-empty-environment))
'
813
&key &allow-other-keys)
'
814
(destructuring-bind (elt-kwd index value-template)
'
815
(template-spec b)
'
816
(declare (ignore elt-kwd)
'
817
(type fixnum index))
'
818
;; Missing index check.
'
819
(unify (aref a index) value-template env)))
'
820
'
821
'
822
(defmethod unify ((a list) (b elt-template)
'
823
&optional (env (make-empty-environment))
'
824
&key &allow-other-keys)
'
825
(destructuring-bind (elt-kwd index value-template)
'
826
(template-spec b)
'
827
(declare (ignore elt-kwd)
'
828
(type fixnum index))
'
829
;; Missing index check.
'
830
(unify (nth index a) value-template env)))
'
831
'
832
'
833
(defmethod unify ((b elt-template) (a sequence)
'
834
&optional (env (make-empty-environment))
'
835
&key &allow-other-keys)
'
836
(unify a b env))
'
837
'
838
'
839
;;; NTH methods.
'
840
'
841
(defmethod unify ((a list) (b nth-template)
'
842
&optional (env (make-empty-environment))
'
843
&key &allow-other-keys)
'
844
(destructuring-bind (nth-kwd index value-template)
'
845
(template-spec b)
'
846
(declare (ignore nth-kwd))
'
847
;; Missing index check.
'
848
(unify (nth index a) value-template env)))
'
849
'
850
(defmethod unify ((b nth-template) (a list)
'
851
&optional (env (make-empty-environment))
'
852
&key &allow-other-keys)
'
853
(unify a b env))
'
854
'
855
'
856
;;;---------------------------------------------------------------------------
'
857
;;; Utilities.
'
858
'
859
(defun unify* (a b &optional (env (make-empty-environment)))
2010-01-15 pix
860
(handler-case
07:59:02 '
861
(unify a b env)
'
862
(unification-failure (c) (values nil c))))
'
863
2009-04-15 mantoniotti
864
10:14:24 '
865
(defun unify-equations (eqns &optional (env (make-empty-environment)))
'
866
(loop for (a b) in eqns
'
867
for result-env = (unify a b env) then (unify a b result-env)
'
868
finally (return result-env)))
'
869
'
870
'
871
(defun unify-equations* (lhss rhss &optional (env (make-empty-environment)))
'
872
(loop for a in lhss
'
873
for b in rhss
'
874
for result-env = (unify a b env) then (unify a b result-env)
'
875
finally (return result-env)))
'
876
'
877
2004-11-17 mantoniotti
878
;;;---------------------------------------------------------------------------
22:19:54 '
879
;;; VAR-UNIFY
'
880
'
881
(defparameter *occurrence-check-p* t)
'
882
'
883
(defgeneric occurs-in-p (var pat env))
'
884
'
885
(defun var-unify (var pat env)
'
886
(if (eq var pat)
'
887
env
'
888
(multiple-value-bind (value foundp)
'
889
(find-variable-value var env)
'
890
(cond (foundp
'
891
(unify value pat env))
'
892
((and *occurrence-check-p*
'
893
(occurs-in-p var pat env))
'
894
(error 'unification-failure
'
895
:format-control "Variable ~S occurs in ~S."
'
896
:format-arguments (list var pat)))
'
897
(t
'
898
(extend-environment var pat env))))))
'
899
'
900
'
901
2006-07-19 mantoniotti
902
#||
2004-11-17 mantoniotti
903
(defmethod occurs-in-p ((var symbol) pat env)
22:19:54 '
904
(cond ((variablep pat)
'
905
(or (eq var pat)
'
906
(multiple-value-bind (value foundp)
'
907
(find-variable-value pat env)
'
908
(when foundp
'
909
(occurs-in-p var value env)))
'
910
))
'
911
((atom pat) nil)
'
912
((consp pat)
'
913
(or (occurs-in-p var (first pat) env)
'
914
(occurs-in-p var (rest pat) env)))
'
915
(t
'
916
(error "unimplemented"))))
2006-07-19 mantoniotti
917
||#
21:52:34 '
918
2004-11-17 mantoniotti
919
22:19:54 '
920
(defmethod occurs-in-p ((var symbol) (pat symbol) env)
'
921
(when (variablep pat)
'
922
(or (eq var pat)
'
923
(multiple-value-bind (value foundp)
'
924
(find-variable-value pat env)
'
925
(when foundp
'
926
(occurs-in-p var value env)))
'
927
)))
'
928
2006-07-19 mantoniotti
929
2004-11-17 mantoniotti
930
(defmethod occurs-in-p ((var symbol) (pat list) env)
22:19:54 '
931
(or (occurs-in-p var (first pat) env)
'
932
(occurs-in-p var (rest pat) env)))
'
933
2006-07-19 mantoniotti
934
21:52:34 '
935
(defmethod occurs-in-p ((var symbol) (pat null) env)
'
936
;; This is needed because of different precedence rules among lisps
'
937
;; in COMPUTE-APPLICABLE-METHODS when NIL has to matched against
'
938
;; SYMBOL and LIST.
2011-04-02 rbrown
939
2006-07-19 mantoniotti
940
;; We know (assume) that VAR is not NIL.
21:52:34 '
941
nil)
'
942
'
943
2004-11-17 mantoniotti
944
(defmethod occurs-in-p ((var symbol) (pat array) env)
22:19:54 '
945
(loop for i from 0 below (array-total-size pat)
'
946
thereis (occurs-in-p var (row-major-aref pat i) env)))
'
947
'
948
'
949
(defmethod occurs-in-p ((var symbol) (pat vector) env) ; This may be faster than the above.
'
950
(some #'(lambda (x) (occurs-in-p var x env)) pat))
'
951
'
952
'
953
(defmethod occurs-in-p ((var symbol) (pat string) env) ; This is useless, but it's here for completeness.
'
954
(declare (ignore env))
'
955
nil)
'
956
'
957
'
958
(defmethod occurs-in-p ((var symbol) (pat number) env)
'
959
(declare (ignore env))
'
960
nil)
'
961
'
962
2009-04-15 mantoniotti
963
(defmethod occurs-in-p ((var symbol) (pat character) env)
10:14:24 '
964
(declare (ignore env))
'
965
nil)
'
966
'
967
2004-11-17 mantoniotti
968
(defmethod occurs-in-p ((var symbol) (pat t) env)
22:19:54 '
969
(declare (ignore env))
2009-04-15 mantoniotti
970
(warn "Occurrence test unimplemented for pattern ~S of type ~S in variable ~S;~@
10:14:24 '
971
returning false."
2004-11-17 mantoniotti
972
pat
2009-04-15 mantoniotti
973
(type-of pat)
10:14:24 '
974
var)
2004-11-17 mantoniotti
975
nil)
22:19:54 '
976
'
977
'
978
(defmethod occurs-in-p ((var t) (pat t) env)
'
979
(declare (ignore env))
'
980
(error "Occurrence test called on a non symbol ~S. Major problem."
'
981
var))
'
982
'
983
;;; end of file -- unifier.lisp --