Wed Apr 15 10:24:28 UTC 2009 mantoniotti * Modified Files: 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. diff -rN -u old-cl-unification-1/lib-dependent/cl-ppcre-template.lisp new-cl-unification-1/lib-dependent/cl-ppcre-template.lisp --- old-cl-unification-1/lib-dependent/cl-ppcre-template.lisp 2013-07-24 17:42:26.000000000 +0000 +++ new-cl-unification-1/lib-dependent/cl-ppcre-template.lisp 2013-07-24 17:42:26.000000000 +0000 @@ -5,6 +5,8 @@ (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow. +(require "CL-PPCRE") + ;;;; REGEXP Templates. ;;;; Another extension of the type specifier language. @@ -120,10 +122,13 @@ (type (or null (integer 0 #.most-positive-fixnum)) end)) (let ((end (or end (length s)))) (declare (type (integer 0 #.most-positive-fixnum) end)) - - (multiple-value-bind (matched-p strings) - (cl-ppcre:scan-to-strings (scanner re-t) s :start start :end end) - (unless matched-p + (multiple-value-bind (m-start m-end r-starts r-ends) + (cl-ppcre:scan (scanner re-t) s :start start :end end) + ;; Maybe SCAN-TO-STRINGS would be simpler to use... + + (declare (type (integer 0 #.most-positive-fixnum) m-start m-end) + (type (vector (integer 0 #.most-positive-fixnum)) r-starts r-ends)) + (unless (and (= start m-start) (= m-end end)) (error 'unification-failure :format-control "String ~S cannot be matched against ~ regular expression ~S." @@ -132,7 +137,9 @@ (let ((vars (variables re-t))) (if (null vars) env - (loop for r-string of-type string across strings + (loop for r-start across r-starts + for r-end across r-ends + for r-string of-type string = (subseq s r-start r-end) for v in vars for result-env = (var-unify v r-string env) then (var-unify v r-string result-env) diff -rN -u old-cl-unification-1/test/unification-tests.lisp new-cl-unification-1/test/unification-tests.lisp --- old-cl-unification-1/test/unification-tests.lisp 2013-07-24 17:42:26.000000000 +0000 +++ new-cl-unification-1/test/unification-tests.lisp 2013-07-24 17:42:26.000000000 +0000 @@ -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) )