repos
/
cl-unification
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Use *unify-string-case-sensitive-p* consistently.
Annotate for file test/unification-tests.lisp
2004-11-17 mantoniotti
1
;;;; -*- Mode: Lisp -*-
22:19:54 '
2
'
3
;;;; unification-tests.lisp --
2011-04-02 rbrown
4
;;;; CL-UNIFICATION test suite. Requires ptester, the public version of
02:47:50 '
5
;;;; Franz's util.test package.
'
6
'
7
(defpackage "IT.UNIMIB.DISCO.MA.CL.EXT.DACF.UNIFICATION.TESTS"
'
8
(:use "CL" "UNIFY" "PTESTER")
'
9
(:nicknames "CL.EXT.DACF.UNIFICATION.TESTS" "UNIFY.TESTS"))
2004-11-17 mantoniotti
10
2009-04-15 mantoniotti
11
(in-package "UNIFY.TESTS")
10:24:28 '
12
2010-01-25 pix
13
;; nil seems like a lousy default for this
07:38:27 '
14
(setf *error-protect-tests* t)
'
15
2004-11-17 mantoniotti
16
(with-tests (:name "basic constant unification")
22:19:54 '
17
(test t (unify:environment-p (unify 42 42)))
'
18
'
19
(test-error (unify 42 12) :condition-type 'unification-failure)
'
20
'
21
(test-error (unify 42 'a) :condition-type 'unification-failure)
'
22
'
23
(test t (unify:environment-p (unify 'a 'a)))
'
24
'
25
(test t (unify:environment-p (unify '(a s d) '(a s d))))
'
26
'
27
(test t (unify:environment-p (unify '(a (s 42) d) '(a (s 42) d))))
'
28
'
29
(test-error (unify '(a (s forty-two) d) '(a (s 42) z))
'
30
:condition-type 'unification-failure)
'
31
'
32
(test t (unify:environment-p (unify #(a s d) #(a s d))))
'
33
'
34
(test t (unify:environment-p (unify #2a((a s d) (a s d))
'
35
#2a((a s d) (a s d)))))
'
36
'
37
(test-error (unify #2a((a s d) (a s d))
'
38
#2a((a s d) (a 42 d)))
'
39
:condition-type 'unification-failure)
'
40
'
41
(test t (unify:environment-p (unify "I am a string" "I am a string")))
'
42
'
43
(test-error (unify "I am a string" "I am A string")
'
44
:condition-type 'unification-failure)
'
45
2011-04-02 rbrown
46
(test t (let ((*unify-string-case-sensitive-p* nil))
2004-11-17 mantoniotti
47
(unify:environment-p (unify "I am a string" "I am A string"))))
22:19:54 '
48
'
49
)
'
50
'
51
'
52
(with-tests (:name "variables unification")
'
53
(test '(42 T) (find-variable-value '?x (unify 42 '?x))
'
54
:multiple-values t)
'
55
(test '(NIL NIL) (find-variable-value '?y (unify 42 '?x))
'
56
:multiple-values t)
'
57
'
58
(test '(42 T) (find-variable-value '?x (unify '?x 42))
'
59
:multiple-values t)
'
60
'
61
(test '(s T) (v? '?x (unify '(a (?x 42) d) '(a (s 42) d)))
'
62
:multiple-values t)
'
63
(test '(s T) (v? '?x (unify '(a (?x 42) d) '(a (s 42) d)))
'
64
:multiple-values t)
'
65
'
66
(test '((?x 42) T) (v? '?z (unify '(a (?x 42) d) '(a ?z d)))
'
67
:multiple-values t :test 'equal)
'
68
'
69
(test '(NIL T) (v? '?x (unify '(a (?x 42) d) '(a (() 42) d)))
'
70
:multiple-values t)
'
71
'
72
(test '(NIL NIL) (v? '?variable (unify '(a (() 42) d) '(a (?x 42) d)))
'
73
:multiple-values t)
'
74
'
75
(test t (unify:environment-p (unify '_ '(1 2 3))))
'
76
'
77
(test t (unify:environment-p (unify '_ '(1 _ 3))))
'
78
'
79
(test t (unify:environment-p (unify '(1 2 _) '(1 _ 3))))
'
80
'
81
(test t (unify:environment-p (unify '(1 2 _) '(1 _ 3))))
'
82
'
83
(test '(2 T) (v? '?x (unify #(1 2 _) #(1 ?x 3)))
'
84
:multiple-values t)
'
85
'
86
(test-error (unify '(1 2 _) #(1 _ 3))
'
87
:condition-type 'unification-failure
'
88
:known-failure t
'
89
:fail-info "Unification on SEQUENCEs does not discriminate type.")
'
90
)
'
91
'
92
'
93
(with-tests (:name "basic templates unification")
'
94
'
95
(with-tests (:name "number templates unification")
'
96
(test t (unify:environment-p (unify #T(number 42) 42)))
'
97
(test t (unify:environment-p (unify 42 #T(number 42))))
'
98
(test t (unify:environment-p (unify 42 #T(integer 42))))
'
99
(test t (unify:environment-p (unify 42 #T(fixnum 42))))
'
100
'
101
(test t (unify:environment-p (unify 42.0 #T(real 42))))
'
102
(test t (unify:environment-p (unify #C(0 1) #T(complex #C(0 1)))))
'
103
'
104
(test '(42 T) (v? '?x (unify #T(number ?x) 42)) :multiple-values t)
2011-04-02 rbrown
105
(test '(42 T) (v? '?x (unify #(0 1 42 3 4 5) #T(sequence 0 1 ?x 3 4 5)))
02:51:32 '
106
:multiple-values t)
2004-11-17 mantoniotti
107
22:19:54 '
108
(test-error (unify 42 #T(float 42.0))
'
109
:condition-type 'unification-failure
'
110
:known-failure t
'
111
:fail-info "Check rules for unification on numeric tower.")
'
112
)
'
113
)
'
114
'
115
2011-04-02 rbrown
116
(eval-when (:compile-toplevel :load-toplevel :execute)
02:37:58 '
117
2004-11-17 mantoniotti
118
(defclass test1 ()
22:19:54 '
119
((a :initarg :a :accessor a)
'
120
(b :initarg :b :accessor b)))
'
121
2009-04-15 mantoniotti
122
(defstruct s-root a)
10:24:28 '
123
(defstruct (s-child (:include s-root)) b)
'
124
2011-04-02 rbrown
125
)
02:37:58 '
126
2004-11-17 mantoniotti
127
(with-tests (:name "advanced templates unification")
22:19:54 '
128
'
129
(test '(a T) (v? '?x (unify #2A((1 #T(symbol ?x) 3) (_ _ _))
'
130
#2A((1 a 3) (q w e))))
'
131
:multiple-values t)
'
132
2009-04-15 mantoniotti
133
(test '(#\Space T) (ignore-errors (v? '?x (unify "This is a string!" #T(elt 4 ?x))))
10:24:28 '
134
:multiple-values t)
'
135
'
136
(test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))
'
137
:multiple-values t)
'
138
'
139
(test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(elt 2 ?x))))
'
140
:multiple-values t)
'
141
'
142
(test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(aref 2 ?x))))
'
143
:multiple-values t)
'
144
'
145
(test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(elt 2 ?x))))
'
146
:multiple-values t)
'
147
'
148
(test '(42 T) (v? '?x (unify #2a((0 1 42 3 4 5)) #T(aref (0 2) ?x)))
'
149
:multiple-values t)
'
150
'
151
(test '(42 T) (v? '?x (unify #T(aref (0 2) 42) #2a((0 1 ?x 3 4 5))))
'
152
:multiple-values t)
'
153
'
154
(test '(42 T) (v? '?x (unify #2a((0 1 ?x 3 4 5)) #T(aref (0 2) 42)))
'
155
:multiple-values t)
'
156
'
157
(test-error (unify #(0 1 42 3 4 5) #T(nth 2 ?x))
'
158
:condition-type 'unification-failure
'
159
:announce t)
2004-11-17 mantoniotti
160
2009-04-15 mantoniotti
161
(test '(foo (1) (2) (3)) (let ((result-env (unify '(0 1 #T(list foo _ &rest ?z) 42)
10:24:28 '
162
'(0 1 (?y bar (1) (2) (3)) 42)))
'
163
)
'
164
(cons (v? '?y result-env)
'
165
(v? '?z result-env)))
'
166
:test #'equal)
2004-11-17 mantoniotti
167
22:19:54 '
168
(test '(2 T) (v? '?x (unify #T(test1 a #T(list 1 ?x 3 &rest) b "woot")
2009-04-15 mantoniotti
169
(make-instance 'test1 :a '(1 2 3) :b "woot")))
10:24:28 '
170
:multiple-values t)
'
171
'
172
(test-error (unify #T(s-root s-root-a '(1 ?x 3 4))
'
173
(make-s-root :a '(1 2 3 4)))
'
174
:condition-type 'unification-failure
'
175
:announce t
'
176
;; #T reader non evaluating sub forms.
'
177
)
'
178
'
179
(test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 4))
'
180
(make-s-root :a '(1 2 3 4))))
'
181
:multiple-values t)
'
182
'
183
(test '(2 T) (v? '?x (unify #T(s-root s-root-a (1 ?x 3 4))
'
184
(make-s-root :a '(1 2 3 4))))
'
185
:multiple-values t)
'
186
'
187
(test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 &rest))
'
188
(make-s-root :a '(1 2 3 4))))
'
189
:multiple-values t)
'
190
'
191
(test '(2 T) (v? '?x (unify #T(s-root s-root-a #(1 ?x 3 4))
'
192
(make-s-root :a #(1 2 3 4))))
'
193
:multiple-values t)
'
194
'
195
(test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(vector 1 ?x 3 &rest))
'
196
(make-s-root :a #(1 2 3 4))))
2004-11-17 mantoniotti
197
:multiple-values t)
22:19:54 '
198
'
199
)
'
200
2010-02-04 pix
201
(define-condition inner-unification-failure (unification-failure) ()
07:20:04 '
202
(:default-initargs :format-control "Inner unification-failure."))
'
203
(define-condition inner-error (simple-error) ()
'
204
(:default-initargs :format-control "Inner error."))
'
205
(define-condition outer-error (simple-error) ()
'
206
(:default-initargs :format-control "Outer error."))
2004-11-17 mantoniotti
207
22:19:54 '
208
(defun nested-match-cases (input)
'
209
(match-case (input)
'
210
('(:a ?a :b #T(list &rest ?bs))
'
211
(loop for b in ?bs
'
212
collect (match-case (b)
'
213
('(:c ?c) ?c)
'
214
('(:d ?d) ?d)
2010-02-04 pix
215
(otherwise (error 'inner-error)))))
07:20:04 '
216
(otherwise (error 'outer-error))))
2010-01-25 pix
217
2010-02-04 pix
218
(defun nested-matchf-cases (input)
07:31:47 '
219
(matchf-case (input)
'
220
((:a ?a :b #T(list &rest ?bs))
'
221
(loop for b in ?bs
'
222
collect (matchf-case (b)
'
223
((:c ?c) ?c)
'
224
((:d ?d) ?d)
'
225
(otherwise (error 'inner-error)))))
'
226
(otherwise (error 'outer-error))))
'
227
2004-11-17 mantoniotti
228
(with-tests (:name "control flow")
2010-02-04 pix
229
(test-error (nested-match-cases '(:a 42 :b 33)) :condition-type 'outer-error)
07:20:04 '
230
(test-error (nested-match-cases '(:a 42 :b (33 42))) :condition-type 'inner-error)
2009-04-15 mantoniotti
231
(test '(42 43 44) (nested-match-cases '(:a 42 :b ((:d 42) (:c 43) (:c 44))))
10:24:28 '
232
:test #'equal)
2010-01-25 pix
233
2010-02-04 pix
234
(test-error (nested-matchf-cases '(:a 42 :b 33)) :condition-type 'outer-error)
07:31:47 '
235
(test-error (nested-matchf-cases '(:a 42 :b (33 42))) :condition-type 'inner-error)
'
236
(test '(42 43 44) (nested-matchf-cases '(:a 42 :b ((:d 42) (:c 43) (:c 44))))
'
237
:test #'equal)
'
238
2010-02-05 pix
239
(test-error (match ('(x) '(x) :errorp nil)
2010-02-04 pix
240
(error 'inner-unification-failure))
07:20:04 '
241
:condition-type 'inner-unification-failure)
2010-01-25 pix
242
07:38:54 '
243
(test-error (matchf ((x) '(x) :errorp nil)
2010-02-04 pix
244
(error 'inner-unification-failure))
07:20:04 '
245
:condition-type 'inner-unification-failure)
2010-01-25 pix
246
07:38:54 '
247
(with-tests (:name "final t-or-otherwise")
'
248
(test :success (matching ()
'
249
(('x 'y) :fail)
'
250
(t :success)))
'
251
(test :success (matching ()
'
252
(('x 'y) :fail)
'
253
(otherwise :success)))
'
254
(test :success (match-case ('x)
'
255
('y :fail)
'
256
(t :success)))
'
257
(test :success (match-case ('x)
'
258
('y :fail)
'
259
(otherwise :success)))
'
260
(test :success (matchf-case ('(x))
'
261
((y) :fail)
'
262
(t :success)))
'
263
(test :success (matchf-case ('(x))
'
264
((y) :fail)
'
265
(otherwise :success))))
'
266
'
267
(test-error (matching ()
'
268
(('x 'y) :fail)
2010-02-04 pix
269
(('x 'x) (error 'inner-unification-failure))
2010-01-25 pix
270
(('?x 'x) x))
2010-02-04 pix
271
:condition-type 'inner-unification-failure)
2010-01-25 pix
272
07:38:54 '
273
(test-error (match-case ('(x))
'
274
('(y) :fail)
2010-02-04 pix
275
('(x) (error 'inner-unification-failure))
2010-01-25 pix
276
('(?x) x))
2010-02-04 pix
277
:condition-type 'inner-unification-failure)
2010-01-25 pix
278
07:38:54 '
279
(test-error (matchf-case ('(x))
'
280
((y) :fail)
2010-02-04 pix
281
((x) (error 'inner-unification-failure))
2010-01-25 pix
282
((?x) x))
2010-02-04 pix
283
:condition-type 'inner-unification-failure)
2010-01-25 pix
284
07:38:54 '
285
(test 'sym (match-case ('(sym))
'
286
('(a) :fail)
'
287
('(b) :fail)
'
288
('(?x) x)))
'
289
'
290
(test 'sym (matchf-case ('(sym))
'
291
((a) :fail)
'
292
((b) :fail)
'
293
((?x) x)))
2004-11-17 mantoniotti
294
)
22:19:54 '
295
'
296
'
297
;;;; end of file -- unification-tests.lisp --