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