[cl-unification-cvs] CVS cl-unification/test

[mantoniotti]

Update of /project/cl-unification/cvsroot/cl-unification/test
In directory cl-net:/tmp/cvs-serv30009/test

Modified Files:
	unification-tests.lisp 
Log Message:
Modified Files:
 	test/unification-tests.lisp 
Added Files:
 	lib-dependent/cl-ppcre-template.lisp 

The cl-ppcre-template reuses E. Weitz's wonderful CL-PPCRE library
to provide a seamless (YMMV) reuse of regular expressions within
CL-UNIFICATION.



--- /project/cl-unification/cvsroot/cl-unification/test/unification-tests.lisp	2008/07/13 13:14:56	1.1
+++ /project/cl-unification/cvsroot/cl-unification/test/unification-tests.lisp	2009/04/15 10:24:28	1.2
@@ -3,6 +3,8 @@
 ;;;; unification-tests.lisp --
 ;;;; CL-UNIFICATION test suite.  Requires Franz's util.test package.
 
+(in-package "UNIFY.TESTS")
+
 (use-package "UNIFY")
 (use-package "UTIL.TEST")
 
@@ -108,24 +110,79 @@
   ((a :initarg :a :accessor a)
    (b :initarg :b :accessor b)))
 
+(defstruct s-root a)
+(defstruct (s-child (:include s-root)) b)
+
 (with-tests (:name "advanced templates unification")
 
   (test '(a T) (v? '?x (unify #2A((1 #T(symbol ?x) 3) (_ _ _))
 			      #2A((1 a 3) (q w e))))
           :multiple-values t)
 
-  (test '(#\f T) (ignore-errors (v? '?x (unify "asdfasdfasdf" #T(elt 3 ?x))))
-        :multiple-values t
-        :known-failure t
-        :fail-info "ELT templates must be fixed.")
-
-  (test '(42 T) (ignore-errors (v? 'x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))
-        :multiple-values t
-        :known-failure t
-        :fail-info "NTH templates must be fixed.")
+  (test '(#\Space T) (ignore-errors (v? '?x (unify "This is a string!" #T(elt 4 ?x))))
+        :multiple-values t)
+
+  (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))
+        :multiple-values t)
+
+  (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(elt 2 ?x))))
+        :multiple-values t)
+
+  (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(aref 2 ?x))))
+        :multiple-values t)
+
+  (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(elt 2 ?x))))
+        :multiple-values t)
+
+  (test '(42 T) (v? '?x (unify #2a((0 1 42 3 4 5)) #T(aref (0 2) ?x)))
+        :multiple-values t)
+
+  (test '(42 T) (v? '?x (unify #T(aref (0 2) 42) #2a((0 1 ?x 3 4 5))))
+        :multiple-values t)
+
+  (test '(42 T) (v? '?x (unify #2a((0 1 ?x 3 4 5)) #T(aref (0 2) 42)))
+        :multiple-values t)
+
+  (test-error (unify #(0 1 42 3 4 5) #T(nth 2 ?x))
+              :condition-type 'unification-failure
+              :announce t)
+
+  (test '(foo (1) (2) (3)) (let ((result-env (unify '(0 1 #T(list foo _ &rest ?z) 42)
+                                                    '(0 1 (?y bar (1) (2) (3)) 42)))
+                                 )
+                             (cons (v? '?y result-env)
+                                   (v? '?z result-env)))
+        :test #'equal)
 
   (test '(2 T) (v? '?x (unify #T(test1 a #T(list 1 ?x 3 &rest) b "woot")
-                           (make-instance 'test1 :a '(1 2 3) :b "woot")))
+                              (make-instance 'test1 :a '(1 2 3) :b "woot")))
+        :multiple-values t)
+
+  (test-error (unify #T(s-root s-root-a '(1 ?x 3 4))
+                     (make-s-root :a '(1 2 3 4)))
+              :condition-type 'unification-failure
+              :announce t
+              ;; #T reader non evaluating sub forms.
+              )
+
+  (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 4))
+                              (make-s-root :a '(1 2 3 4))))
+        :multiple-values t)
+
+  (test '(2 T) (v? '?x (unify #T(s-root s-root-a (1 ?x 3 4))
+                              (make-s-root :a '(1 2 3 4))))
+        :multiple-values t)
+
+  (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 &rest))
+                              (make-s-root :a '(1 2 3 4))))
+        :multiple-values t)
+
+  (test '(2 T) (v? '?x (unify #T(s-root s-root-a #(1 ?x 3 4))
+                              (make-s-root :a #(1 2 3 4))))
+        :multiple-values t)
+
+  (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(vector 1 ?x 3 &rest))
+                              (make-s-root :a #(1 2 3 4))))
         :multiple-values t)
 
   )
@@ -139,11 +196,15 @@
 		     ('(:c ?c)   ?c)
 		     ('(:d ?d)   ?d)
 		     (otherwise (error "error-inner")))))
-   (otherwise "error-outer")))
+   (otherwise (error "error-outer"))))
 
 (with-tests (:name "control flow")
-  (test "error-outer" (nested-match-cases '(:a 42 :b 33)) :test 'string=)
+  (test-error (nested-match-cases '(:a 42 :b 33)) :announce t)
+
+  (test-error (nested-match-cases '(:a 42 :b (33 42))) :announce t)
 
+  (test '(42 43 44) (nested-match-cases '(:a 42 :b ((:d 42) (:c 43) (:c 44))))
+        :test #'equal)
   )