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-20 16:15:26.000000000 +0000
+++ new-cl-unification-1/lib-dependent/cl-ppcre-template.lisp 2013-07-20 16:15: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-20 16:15:26.000000000 +0000
+++ new-cl-unification-1/test/unification-tests.lisp 2013-07-20 16:15: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)
)