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 --