From mantoniotti at common-lisp.net  Wed Apr 15 10:05:58 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:05:58 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu20E-0006uk-Um@common-lisp.net>

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

Modified Files:
	apply-substitution.lisp 
Log Message:
Added some functionality and comments.


--- /project/cl-unification/cvsroot/cl-unification/apply-substitution.lisp	2008/07/10 17:39:16	1.2
+++ /project/cl-unification/cvsroot/cl-unification/apply-substitution.lisp	2009/04/15 10:05:58	1.3
@@ -9,28 +9,68 @@
 ;;;---------------------------------------------------------------------------
 ;;; Substitution application.
 
-(defgeneric apply-substitution (substitution item))
+;;; apply-substitution --
+;;;
+;;; EXCLUDE-VARS are variables that will just pass through (a list for
+;;; the time being).
 
+(defgeneric apply-substitution (substitution item &optional exclude-vars))
 
-(defmethod apply-substitution ((substitution environment) (s symbol))
+
+(defmethod apply-substitution ((substitution environment) (s symbol)
+                               &optional (exclude-vars ()))
+  (declare (type list exclude-vars))
   (cond ((variable-any-p s) s)
         ((variablep s)
-         (multiple-value-bind (val foundp)
-             (find-variable-value s substitution)
-           (cond (foundp val)
-                 (t (warn "~S is a free variable in the current environment."
-			  s)
-                    s))))
+         (if (member s exclude-vars :test #'eq)
+             s
+             (multiple-value-bind (val foundp)
+                 (find-variable-value s substitution)
+               (cond (foundp val)
+                     (t (warn "~S is a free variable in the current environment."
+                              s)
+                        s))))
+         )
         (t s)))
 
 
-(defmethod apply-substitution ((substitution environment) (l cons))
-  (cons (apply-substitution substitution (first l))
-        (apply-substitution substitution (rest l))))
+(defmethod apply-substitution ((substitution environment) (l cons)
+                               &optional (exclude-vars ()))
+  (declare (type list exclude-vars))
+  (cons (apply-substitution substitution (first l) exclude-vars)
+        (apply-substitution substitution (rest l) exclude-vars)))
+
 
-(defmethod apply-substitution ((substitution environment) (l null))
+(defmethod apply-substitution ((substitution environment) (l null)
+                               &optional exclude-vars)
+  (declare (ignore exclude-vars))
   '())
 
+
+;;; compose-substitions --
+;;; The definition is a direct translation of TPL's definition at page 318.
+;;; Usually these are done by directly composing and currying
+;;; functions in ML/Haskell derivatives, but that is just being "lazy".
+;;; The current definition may be too "eager", but the "correct"
+;;; semantics should be preserved.
+
+(defun compose-substitutions (env2 env1) ; note the order.
+  (declare (type environment env2 env1))
+
+  (loop for env1-frame in (environment-frames env1)
+        collect
+        (loop for (var . term) in (frame-bindings env1-frame)
+              collect (make-binding var (apply-substitution env2 term))
+              into result-bindings
+              finally (return (make-frame result-bindings)))
+        into frames
+        finally (return (make-environment :frames frames))))
+                      
+        
+
+
+;;; ground-term --
+
 (defun ground-term (term &optional (substitution (make-empty-environment)))
   (apply-substitution substitution term))
 




From mantoniotti at common-lisp.net  Wed Apr 15 10:06:40 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:06:40 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu20u-0006wA-Mj@common-lisp.net>

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

Modified Files:
	cl-unification.asd 
Log Message:
Fixed a few snags and added "lib-dependent" module.


--- /project/cl-unification/cvsroot/cl-unification/cl-unification.asd	2007/11/09 13:34:18	1.1
+++ /project/cl-unification/cvsroot/cl-unification/cl-unification.asd	2009/04/15 10:06:40	1.2
@@ -13,6 +13,12 @@
 			     (:file "templates-hierarchy")
 			     (:file "unifier")
 			     (:file "match-block")
-			     (:file "apply-substitution")))
+			     (:file "apply-substitution")
+                             (:module "lib-dependent"
+                              :depends-on ("templates-hierarchy" "unifier")
+                              :components (
+                                           #+cl-ppcre
+                                           (:file "cl-ppcre-template")
+                                           ))))
 
 ;;;; end of file -- cl-unification.asd --




From mantoniotti at common-lisp.net  Wed Apr 15 10:09:43 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:09:43 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu23r-000701-DM@common-lisp.net>

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

Modified Files:
	cl-unification.system 
Log Message:
Fixed a few snags and added "lib-dependent" module.


--- /project/cl-unification/cvsroot/cl-unification/cl-unification.system	2008/07/13 12:51:14	1.2
+++ /project/cl-unification/cvsroot/cl-unification/cl-unification.system	2009/04/15 10:09:43	1.3
@@ -12,6 +12,13 @@
 		 "templates-hierarchy"
 		 "unifier"
 		 "match-block"
-		 "apply-substitution"))
+		 "apply-substitution"
+                 (:module "lib-dependent"
+                  :depends-on ("templates-hierarchy" "unifier")
+                  :components (
+                               #+cl-ppcre
+                               (:file "cl-ppcre-template")
+                               ))
+                 ))
    
 ;;; end of file -- cl-unification.system --




From mantoniotti at common-lisp.net  Wed Apr 15 10:10:25 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:10:25 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu24X-000719-9Q@common-lisp.net>

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

Modified Files:
	unification-package.lisp 
Log Message:
Added exports of a few symbols.


--- /project/cl-unification/cvsroot/cl-unification/unification-package.lisp	2008/07/13 13:10:48	1.4
+++ /project/cl-unification/cvsroot/cl-unification/unification-package.lisp	2009/04/15 10:10:25	1.5
@@ -3,6 +3,7 @@
 (defpackage "CL.EXT.DACF.UNIFICATION" (:use "CL")
   (:nicknames "UNIFY")
   (:documentation "The CL.EXT.DACF.UNIFICATION Package.
+
 This package contains all the definitions necessary for the general
 Common Lisp unifier to work.
 The package also has the \"UNIFY\" nickname.")
@@ -31,7 +32,14 @@
 
   (:export
    "MATCH"
+   "MATCHF"
    "MATCHING"
-   "MATCH-CASE"))
+   "MATCH-CASE")
+
+  (:export
+   "UNIFY*"
+   "UNIFY-EQUATIONS"
+   "UNIFY-EQUATIONS*")
+  )
 
 ;;; end of file -- unification-package.lisp --




From mantoniotti at common-lisp.net  Wed Apr 15 10:12:22 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:12:22 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu26Q-00073T-4H@common-lisp.net>

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

Modified Files:
	variables.lisp 
Log Message:
Some 'diff' unfathomable change happened.


--- /project/cl-unification/cvsroot/cl-unification/variables.lisp	2008/07/13 13:10:48	1.2
+++ /project/cl-unification/cvsroot/cl-unification/variables.lisp	2009/04/15 10:12:22	1.3
@@ -3,7 +3,7 @@
 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
 
 
-(defun make-var-name (&optional (s (gensym)) (package *package*))
+(defun make-var-name (&optional (s (gensym "UNIFVAR-")) (package *package*))
   (intern (concatenate 'string "?" (symbol-name s)) package))
 
 




From mantoniotti at common-lisp.net  Wed Apr 15 10:14:24 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:14:24 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu28O-00075A-LJ@common-lisp.net>

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

Modified Files:
	unifier.lisp 
Log Message:
Major API change to 'unify'.  It now accepts keywords.  Old code
shouls not be affected, but new code is now more flexible.  Look the
the STRING and (new) CHARACTER methods to see how this change is
affecting the code.


--- /project/cl-unification/cvsroot/cl-unification/unifier.lisp	2006/07/19 21:52:34	1.5
+++ /project/cl-unification/cvsroot/cl-unification/unifier.lisp	2009/04/15 10:14:24	1.6
@@ -5,7 +5,7 @@
 
 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
 
-(defgeneric unify (a b &optional env)
+(defgeneric unify (a b &optional env &key &allow-other-keys)
   (:documentation
    "Unifies two objects A and B given a substitution ENV.
 A is a Common Lisp object and B is either a Common Lisp object or a
@@ -22,7 +22,9 @@
 ;;;===========================================================================
 ;;; Simple, non template methods.
 
-(defmethod unify ((a symbol) (b list) &optional (env (make-empty-environment)))
+(defmethod unify ((a symbol) (b list)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   "Unifies a symbol A and a list B in an environment ENV.
 If A is not a variable then an error of type UNIFICATION-FAILURE is
 signaled. If A is a unification variable, then the environment ENV is
@@ -35,7 +37,9 @@
                   :format-arguments (list a b)))))
 
 
-(defmethod unify ((b list) (a symbol) &optional (env (make-empty-environment)))
+(defmethod unify ((b list) (a symbol)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   "Unifies a symbol B and a list A in an environment ENV.
 If A is not a variable then an error of type UNIFICATION-FAILURE is
 signaled. If A is a unification variable, then the environment ENV is
@@ -48,7 +52,9 @@
                   :format-arguments (list b a)))))
 
 
-(defmethod unify ((a list) (b list) &optional (env (make-empty-environment)))
+(defmethod unify ((a list) (b list)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   "Unifies a list A and a list B in an environment ENV.
 The unification procedure proceedes recursively on each element of
 both lists. If two elements cannot be unified then an error of type
@@ -58,7 +64,9 @@
 
 
 
-(defmethod unify ((a number) (b number) &optional (env (make-empty-environment)))
+(defmethod unify ((a number) (b number)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   "Unifies two numbers A and B.
 Two numbers unify only if and only if they are equal as per the function #'=, in
 which case an unmodified envirironment ENV is returned.
@@ -72,9 +80,35 @@
              :format-arguments (list a b))))
 
 
-(defparameter *unify-string-case-insensitive-p* nil)
+(defparameter *unify-string-case-sensitive-p* t)
 
-(defmethod unify ((a string) (b string) &optional (env (make-empty-environment)))
+(defmethod unify ((a character) (b character)
+                  &optional (env (make-empty-environment))
+                  &key
+                  (case-sensitive *unify-string-case-sensitive-p*)
+                  &allow-other-keys)
+  "Unifies two strings A and B.
+Two CHARACTERs A and B unify if and only if they satisfy either #'CHAR= or
+#'CHAR-EQUAL. The choice of which of test to perform (#'CHAR= or #'CHAR-EQUAL)
+is made according to the value of the variable
+*UNIFY-STRING-CASE-INSENSITIVE-P*, which defaults to NIL.
+If A and B unify then an unmodified environment ENV is returned,
+otherwise an error of type UNIFICATION-FAILURE is signaled."
+  (cond ((and case-sensitive (char= a b))
+         env)
+        ((char-equal a b)
+         env)
+        (t
+         (error 'unification-failure
+                :format-control "Connot unify two different characters: ~S ~S."
+                :format-arguments (list a b)))))
+
+
+(defmethod unify ((a string) (b string)
+                  &optional (env (make-empty-environment))
+                  &key
+                  (case-sensitive *unify-string-case-sensitive-p*)
+                  &allow-other-keys)
   "Unifies two strings A and B.
 Two strings A and B unify if and only if they satisfy either #'STRING= or
 #'STRING-EQUAL. The choice of which of test to perform (#'STRING= or #'STRING-EQUAL)
@@ -82,9 +116,9 @@
 *UNIFY-STRING-CASE-INSENSITIVE-P*, which defaults to NIL.
 If A and B unify then an unmodified environment ENV is returned,
 otherwise an error of type UNIFICATION-FAILURE is signaled."
-  (cond ((and *unify-string-case-insensitive-p* (string-equal a b))
+  (cond ((and case-sensitive (string= a b))
          env)
-        ((string= a b)
+        ((string-equal a b)
          env)
         (t
          (error 'unification-failure
@@ -92,7 +126,9 @@
                 :format-arguments (list a b)))))
 
 
-(defmethod unify ((a symbol) (b string) &optional (env (make-empty-environment)))
+(defmethod unify ((a symbol) (b string)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (cond ((variable-any-p a) env)
         ((variablep a) (var-unify a b env))
         (t (error 'unification-failure
@@ -100,7 +136,9 @@
 		  :format-arguments (list a b)))))
 
 
-(defmethod unify ((b string) (a symbol) &optional (env (make-empty-environment)))
+(defmethod unify ((b string) (a symbol)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (cond ((variable-any-p a) env)
         ((variablep a) (var-unify a b env))
         (t (error 'unification-failure
@@ -108,7 +146,9 @@
                   :format-arguments (list b a)))))
 
 
-(defmethod unify ((a symbol) (b symbol) &optional (env (make-empty-environment)))
+(defmethod unify ((a symbol) (b symbol)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (cond ((variable-any-p a) env)
         ((variablep a) (var-unify a b env))
         ((variable-any-p b) env)
@@ -119,27 +159,36 @@
                   :format-arguments (list a b)))))
 
 
-(defmethod unify ((a symbol) (b t) &optional (env (make-empty-environment)))
+(defmethod unify ((a symbol) (b t)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (cond ((variable-any-p a) env)
         ((variablep a) (var-unify a b env))
         (t (call-next-method))))
 
 
-(defmethod unify ((b t) (a symbol) &optional (env (make-empty-environment)))
+(defmethod unify ((b t) (a symbol)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (cond ((variable-any-p a) env)
         ((variablep a) (var-unify a b env))
         (t (call-next-method))))
 
 
-(defmethod unify ((a symbol) (b array) &optional (env (make-empty-environment)))
+(defmethod unify ((a symbol) (b array)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (cond ((variable-any-p a) env)
         ((variablep a) (var-unify a b env))
         (t (error 'unification-failure
-                  :format-control "Cannot unify a symbol with an array or vector: ~S and ~S."
+                  :format-control "Cannot unify a symbol with ~
+                                   an array or vector: ~S and ~S."
                   :format-arguments (list a b)))))
 
 
-(defmethod unify ((b array) (a symbol) &optional (env (make-empty-environment)))
+(defmethod unify ((b array) (a symbol)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (cond ((variable-any-p a) env)
         ((variablep a) (var-unify a b env))
         (t (error 'unification-failure
@@ -147,7 +196,9 @@
                   :format-arguments (list a b)))))
 
 
-(defmethod unify ((as vector) (bs vector) &optional (env (make-empty-environment)))
+(defmethod unify ((as vector) (bs vector)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unless (= (length as) (length bs))
     (error 'unification-failure
            :format-control "Cannot unify two vectors of different length: ~D and ~D."
@@ -158,7 +209,9 @@
         finally (return mgu)))
 
 
-(defmethod unify ((s1 sequence) (s2 sequence) &optional (env (make-empty-environment)))
+(defmethod unify ((s1 sequence) (s2 sequence)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unless (= (length s1) (length s2))
     (error 'unification-failure
            :format-control "Cannot unify two sequences of different length: ~D and ~D."
@@ -186,7 +239,9 @@
   (unify a b env))
 
 
-(defmethod unify ((as array) (bs array) &optional (env (make-empty-environment)))
+(defmethod unify ((as array) (bs array)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unless (= (array-total-size as) (array-total-size bs))
     (error 'unification-failure
            :format-control "Cannot unify two arrays of different total size: ~D and ~D."
@@ -200,7 +255,9 @@
 
 ;;; Catch all method.
 
-(defmethod unify ((a t) (b t) &optional (env (make-empty-environment)))
+(defmethod unify ((a t) (b t)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (if (equalp a b)
       env
       (error 'unification-failure
@@ -229,10 +286,13 @@
 
 ;;; Special catch all method.
 
-(defmethod unify ((x template) (y template) &optional (env (make-empty-environment)))
+(defmethod unify ((x template) (y template)
+                  &optional (env)
+                  &key &allow-other-keys)
   (declare (ignore env))
   (error 'unification-failure
-           :format-control "Unification of two templates of type ~A and ~A has not been yet implemented."
+           :format-control "Unification of two templates of type ~A and ~A ~
+                            has not been yet implemented."
            :format-arguments (list (class-name (class-of x))
                                    (class-name (class-of y)))))
 
@@ -241,45 +301,58 @@
 ;;; NIL special unification methods.
 
 (defmethod unify ((x null) (y null)
-		  &optional (env (make-empty-environment)))
+		  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   env)
 
 
 (defmethod unify ((x null) (nt nil-template)
-		  &optional (env (make-empty-environment)))
+		  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   env)
 
 
 (defmethod unify ((nt nil-template) (x null)
-		  &optional (env (make-empty-environment)))
+		  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   env)
 
 
 (defmethod unify ((nt1 nil-template) (nt2 nil-template)
-		  &optional (env (make-empty-environment)))
+		  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   env)
 
 
 ;;;---------------------------------------------------------------------------
 ;;; Symbol methods.
 
-(defmethod unify ((a symbol) (b symbol-template) &optional (env (make-empty-environment)))
+(defmethod unify ((a symbol) (b symbol-template)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (cond ((variable-any-p a) env)
         ((variablep a) (var-unify a b env))
         (t (unify a (symbol-template-symbol b) env))))
 
 
-(defmethod unify ((b symbol-template) (a symbol) &optional (env (make-empty-environment)))
+(defmethod unify ((b symbol-template) (a symbol)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unify a b env))
 
 
-(defmethod unify ((a symbol) (b template) &optional (env (make-empty-environment)))
+(defmethod unify ((a symbol) (b template)
+                  &optional (env)
+                  &key &allow-other-keys)
   (declare (ignore env))
   (error 'unification-failure
          :format-control "Cannot unify symbol ~S with template ~S."
          :format-arguments (list a b)))
 
-(defmethod unify ((b template) (a symbol) &optional (env (make-empty-environment)))
+
+(defmethod unify ((b template) (a symbol)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unify a b env))
 
 
@@ -287,47 +360,74 @@
 ;;;---------------------------------------------------------------------------
 ;;; Number template methods.
 
-(defmethod unify ((a number) (b number-template) &optional (env (make-empty-environment)))
+(defmethod unify ((a number) (b number-template)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unify a (number-template-number b) env))
 
 
-(defmethod unify ((b number-template) (a number) &optional (env (make-empty-environment)))
+(defmethod unify ((b number-template) (a number)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unify a b env))
 
-(defmethod unify ((a number) (b template) &optional (env (make-empty-environment)))
+(defmethod unify ((a number) (b template)
+                  &optional (env)
+                  &key &allow-other-keys)
   (declare (ignore env))
   (error 'unification-failure
          :format-control "Cannot unify the number ~S with template ~S."
          :format-arguments (list a b)))
 
-(defmethod unify ((b template) (a number) &optional (env (make-empty-environment)))
+(defmethod unify ((b template) (a number)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unify a b env))
 
 
 ;;;---------------------------------------------------------------------------
 ;;; Sequence (List) template methods
 
-(defmethod unify ((a sequence) (b template) &optional (env (make-empty-environment)))
+(defmethod unify ((a sequence) (b template)
+                  &optional (env)
+                  &key &allow-other-keys)
   (declare (ignore env))
   (error 'unification-failure
-         :format-control "Cannot unify a sequence with a non sequence or non sequence access template: ~S ~S."
+         :format-control "Cannot unify a sequence with a non sequence ~
+                         or non sequence access template: ~S and ~S."
          :format-arguments (list a b)))
 
 
-(defmethod unify ((b template) (a sequence) &optional (env (make-empty-environment)))
+(defmethod unify ((b template) (a sequence)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unify a b env))
 
 
+#| Needs to be fixed.
+(defmethod unify ((a list) (b lambda-template) &optional (env (make-empty-environment)))
+  (unify a (template-spec b) env))
+
+
+(defmethod unify ((b lambda-template) (a list) &optional (env (make-empty-environment)))
+  (unify (template-spec b) a env))
+|#
+
+
 ;;; The next is incomplete and does not signal appropriate errors.
 
-(defmethod unify ((a list) (b template) &optional (env (make-empty-environment)))
+(defmethod unify ((a list) (b template)
+                  &optional (env)
+                  &key &allow-other-keys)
   (declare (ignore env))
   (error 'unification-failure
          :format-control "Cannot unify a list with a non-list template: ~S ~S."
          :format-arguments (list a b)))
 
 
-(defmethod unify ((a list) (b sequence-template) &optional (env (make-empty-environment)))
+(defmethod unify ((a list) (b sequence-template)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (let ((template-lambda-list (sequence-template-lambda-list b))
         (ll (list-length a))
         )
@@ -355,7 +455,9 @@
 
 
 
-(defmethod unify ((b template) (a list) &optional (env (make-empty-environment)))
+(defmethod unify ((b template) (a list)
+                  &optional (env (make-empty-environment))
+                  &key &allow-other-keys)
   (unify a b env))

[368 lines skipped]




From mantoniotti at common-lisp.net  Wed Apr 15 10:14:59 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:14:59 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu28x-00076I-D7@common-lisp.net>

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

Modified Files:
	COPYING 
Log Message:
Dates updated.


--- /project/cl-unification/cvsroot/cl-unification/COPYING	2008/07/13 13:17:29	1.4
+++ /project/cl-unification/cvsroot/cl-unification/COPYING	2009/04/15 10:14:59	1.5
@@ -1,4 +1,4 @@
-Copyright (c) 2004-2008 Marco Antoniotti
+Copyright (c) 2004-2009 Marco Antoniotti
 All rights reserved.
  
 Permission is hereby granted, without written agreement and without




From mantoniotti at common-lisp.net  Wed Apr 15 10:16:24 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:16:24 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu2AK-00077w-UB@common-lisp.net>

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

Modified Files:
	match-block.lisp 
Log Message:
Added MATCHF (whose name may change) to simplify the
'destructuring-bind'-like syntax and behavior of the matching
facilities.


--- /project/cl-unification/cvsroot/cl-unification/match-block.lisp	2007/11/09 13:43:20	1.8
+++ /project/cl-unification/cvsroot/cl-unification/match-block.lisp	2009/04/15 10:16:24	1.9
@@ -13,6 +13,7 @@
 
 (defmacro match ((template object
                            &key
+                           (match-named nil)
                            (substitution '(make-empty-environment))
                            (errorp t)
                            (error-value nil))
@@ -32,6 +33,9 @@
 whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
 raising from the evaluation of FORMS will also be caught and handled
 according to ERRORP settings.)
+
+If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
+is set up around the matching code.
 "
   (let ((template-vars (collect-template-vars template))
         (env-var (gensym "UNIFICATION-ENV-"))
@@ -45,7 +49,73 @@
                                                          ,env-var))
                                `(,(clean-unify-var-name v) ,v))))
            )
-      `(block nil
+      `(block ,match-named
+         (handler-case
+             (let* ((,env-var (unify ,template ,object ,substitution))
+                    ,@(generate-var-bindings)
+                    )
+	       (declare (ignorable ,@(mapcar #'first
+                                             (generate-var-bindings))))
+               , at forms)
+           
+           ;; Yes.  The above is sligthly wasteful.
+
+           (unification-failure (uf)
+                                (if ,errorp
+                                    (error uf)
+                                    ,error-value))
+           )))))
+
+
+(defmacro matchf ((template object
+                            &key
+                            (match-named nil)
+                            (substitution '(make-empty-environment))
+                            (errorp t)
+                            (error-value nil))
+                  &body forms)
+  "Sets up a lexical environment to evaluate FORMS after an unification.
+
+MATCHF unifies a TEMPLATE and an OBJECT and then sets up a lexical
+environment where the variables present in the template are bound
+lexically.  Note that both variable names '?FOO' and 'FOO' are bound
+for convenience.
+
+MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will
+generate a template at read-time).
+
+The MATCHF form returns the values returned by the evaluation of the
+last of the FORMS.
+
+If ERRORP is non-NIL (the default) then the form raises a
+UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
+whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
+raising from the evaluation of FORMS will also be caught and handled
+according to ERRORP settings.)
+
+If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
+is set up around the matching code.
+"
+  (let ((template-vars (collect-template-vars template))
+        (env-var (gensym "UNIFICATION-ENV-"))
+        (template (cond ((variablep template)
+                         `',template) ; Logical variables are special-cased.
+                        ((listp template) ; Same for lists.
+                         (make-instance 'list-template
+                                        :spec (cons 'list template)))
+                        ;`',template)
+                        (t
+                         template)))
+        )
+    ;; Logical variables and lists are special cased for convenience.
+    ;; Lists are especially inteded as abbreviation for destructuring.
+    (flet ((generate-var-bindings ()
+             (loop for v in template-vars
+                   nconc (list `(,v (find-variable-value ',v
+                                                         ,env-var))
+                               `(,(clean-unify-var-name v) ,v))))
+           )
+      `(block ,match-named
          (handler-case
              (let* ((,env-var (unify ,template ,object ,substitution))
                     ,@(generate-var-bindings)
@@ -70,7 +140,8 @@
 
 (defmacro matching ((&key errorp
                           (default-substitution
-                           (make-empty-environment)))
+                           (make-empty-environment))
+                          (matching-named nil))
                     &rest match-clauses)
   "MATCHING sets up a COND-like environment for multiple template matching clauses.
 
@@ -150,7 +221,7 @@
                                            match-clauses))
            )
 
-      `(block matching
+      `(block ,matching-named
          (let ,match-clauses-env-vars
 	   (declare (dynamic-extent , at match-clauses-env-vars))
            (cond ,@(mapcar (lambda (match-clause match-clause-env-var)
@@ -171,11 +242,11 @@
 ;;; Notes:
 ;;;
 ;;; [MA 20071109]
-;;; When the construction of the inner MATCH clauses could be done
+;;; The construction of the inner MATCH clauses could be done
 ;;; more intelligently by supplying :ERRORP NIL, thus avoiding the
 ;;; HANDLER-CASEs, which are quite expensive.  Any takers?
 
-(defmacro match-case ((object &key errorp default-substitution)
+(defmacro match-case ((object &key errorp default-substitution match-case-named)
                       &rest clauses)
   "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.
 
@@ -227,9 +298,10 @@
 		     `(handler-case (match (,pattern ,object-var)
 				      , at body)
 		        (unification-failure ()
-			                     ,(generate-matchers (cdr clauses))))))))
-      `(let ((,object-var ,object))
-	 ,(generate-matchers non-otherwise-clauses)))))
+			  ,(generate-matchers (cdr clauses))))))))
+      `(block ,match-case-named
+         (let ((,object-var ,object))
+           ,(generate-matchers non-otherwise-clauses))))))
 
 ;;;;---------------------------------------------------------------------------
 ;;;; Testing.




From mantoniotti at common-lisp.net  Wed Apr 15 10:17:48 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:17:48 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu2Bg-00079g-9Y@common-lisp.net>

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

Modified Files:
	substitutions.lisp 
Log Message:
Added some functionality to extract all variables and/or all values
from an environment or a frame.


--- /project/cl-unification/cvsroot/cl-unification/substitutions.lisp	2008/07/13 13:10:48	1.4
+++ /project/cl-unification/cvsroot/cl-unification/substitutions.lisp	2009/04/15 10:17:48	1.5
@@ -39,6 +39,11 @@
   (setf (cdr b) v))
 
 
+(defun bindings-values (bindings) (mapcar #'cdr bindings))
+
+(defun bindings-keys (bindings) (mapcar #'car bindings))
+
+
 
 (define-condition unification-variable-unbound (unbound-variable)
   ()
@@ -51,7 +56,7 @@
 ;;;---------------------------------------------------------------------------
 ;;; Frames.
 
-(defstruct frame
+(defstruct (frame (:constructor make-frame (&optional bindings)))
   (bindings () :type bindings))
 
 (defun empty-frame-p (f)
@@ -72,6 +77,13 @@
         (values (cdr b) t)
         (values nil nil))))
 
+(defun frame-variables (frame)
+  (mapcar 'binding-variable (frame-bindings frame)))
+
+
+(defun frame-values (frame)
+  (mapcar 'binding-value (frame-bindings frame)))
+
 
 ;;;---------------------------------------------------------------------------
 ;;; Environments.
@@ -106,10 +118,12 @@
 (defun make-shared-environment (env)
   (make-environment :frames (environment-frames env)))
 
-(defun empty-environment-p (env &aux (env-frames (environment-frames env)))
+(defun empty-environment-p (env)
   (declare (type environment env))
-  (and (= 1 (list-length env-frames))
-       (empty-frame-p (first env-frames))))
+  (let ((env-frames (environment-frames env)))
+    (declare (type list env-frames))
+    (and (= 1 (list-length env-frames))
+         (empty-frame-p (first env-frames)))))
 
 (defparameter *null-environment* (make-empty-environment))
 
@@ -131,19 +145,43 @@
 
 
 
-(defun extend-environment (var pat env)
+(defun extend-environment (var pat &optional (env (make-empty-environment)))
   (let ((first-frame (first-frame env)))
     (setf (frame-bindings first-frame)
           (extend-bindings var pat (frame-bindings first-frame)))
     env))
 
 
+(defun fill-environment (vars pats &optional (env (make-empty-environment)))
+  (map nil (lambda (v p) (extend-environment v p env)) vars pats)
+  env)
+
+
+(defun fill-environment* (vars-pats &optional (env (make-empty-environment)))
+  (loop for (v . p) in vars-pats do (extend-environment v p env))
+  env)
+
+
+(declaim (inline v?))
+(declaim (ftype (function (symbol environment &optional boolean)
+                          (values t boolean))
+                find-variable-value
+                v?))
+
 (defun v? (s env &optional (plain-symbol-p nil))
   (find-variable-value (if plain-symbol-p
                            (make-var-name s)
                            s)
                        env))
-                           
+
+
+(defun environment-variables (env)
+  (mapcan #'frame-variables (environment-frames env)))
+
+(defun environment-values (env)
+  (mapcan #'frame-values (environment-frames env)))
+
+
 
 
 ;;;; end of file -- substitutions.lisp --




From mantoniotti at common-lisp.net  Wed Apr 15 10:19:00 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:19:00 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu2Cq-0007B4-20@common-lisp.net>

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

Modified Files:
	templates-hierarchy.lisp 
Log Message:
Added LAMBDA-TEMPLATE.


--- /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp	2008/07/13 13:10:48	1.4
+++ /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp	2009/04/15 10:18:59	1.5
@@ -1,4 +1,6 @@
-;;; -*- Mode: Lisp -*-
+;;;; -*- Mode: Lisp -*-
+
+;;;; templates-hierarchy.lisp --
 
 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
 
@@ -121,6 +123,15 @@
   (:method ((x list-template)) t)
   (:method ((x t)) nil))
 
+
+(defclass lambda-template (list-template expression-template) ())
+
+(defgeneric lambda-template-p (x)
+  (:method ((x lambda-template)) t)
+  (:method ((x t)) nil))
+
+
+
 (defclass array-template (type-template) ())
 
 (defgeneric array-template-p (x)
@@ -332,6 +343,9 @@
 (defmethod make-template ((kind (eql 'list)) (spec cons))
   (make-instance 'list-template :spec spec))
 
+(defmethod make-template ((kind (eql 'lambda)) (spec cons))
+  (make-instance 'lambda-template :spec spec))
+
 (defmethod make-template ((kind (eql 'vector)) (spec cons))
   (make-instance 'vector-template :spec spec))
 




From mantoniotti at common-lisp.net  Wed Apr 15 10:19:48 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:19:48 -0400
Subject: [cl-unification-cvs] CVS cl-unification/lib-dependent
Message-ID: <E1Lu2Dc-0007CC-Dc@common-lisp.net>

Update of /project/cl-unification/cvsroot/cl-unification/lib-dependent
In directory cl-net:/tmp/cvs-serv27661/lib-dependent

Log Message:
Directory /project/cl-unification/cvsroot/cl-unification/lib-dependent added to the repository






From mantoniotti at common-lisp.net  Wed Apr 15 10:24:28 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:24:28 -0400
Subject: [cl-unification-cvs] CVS cl-unification/lib-dependent
Message-ID: <E1Lu2I8-0007rJ-5j@common-lisp.net>

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

Added Files:
	cl-ppcre-template.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/lib-dependent/cl-ppcre-template.lisp	2009/04/15 10:24:28	NONE
+++ /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.lisp	2009/04/15 10:24:28	1.1
;;;; -*- Mode: Lisp -*-

;;;; cl-ppcre-template.lisp --
;;;; REGEXP template dependent on CL-PPCRE.

(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.

(require "CL-PPCRE")


;;;; REGEXP Templates.
;;;; Another extension of the type specifier language.

;;;; A template can also be
;;;;
;;;;    <template> ::= #| templates from template-hierarchy.lisp |#
;;;;               |   <regexp template>
;;;;
;;;; Hairier REGEXP template spec syntax:
;;;;
;;;; (regexp|regular-expression) <REGEXP> &optional <unification vars> &rest <keys>
;;;;
;;;; where
;;;;
;;;; <REGEXP> ::= <a CL-PPCRE regexp string or tree>
;;;; <unification vars> ::= '(' <variable>* ')'
;;;; <keys> ::= <CL-PPCRE (constant) keys to be passed to CL-PPCRE:CREATE-SCANNER>

(defclass regular-expression-template (string-template)
  ((scanner :reader scanner)
   (regexp :reader regular-expression)
   (vars :reader variables
         :reader registers
         :type list)
   )
  (:documentation "The Regular Expression Template.

A template for matching strings using regular expressions.
The actual matching is done thankes to the CL-PPCRE library.")
  )



(defgeneric regular-expression-template-p (x)
  (:method ((x regular-expression-template)) t)
  (:method ((x t)) nil))


(defmethod make-template ((kind (eql 'regexp)) (spec cons))
  (make-instance 'regular-expression-template :spec spec))

(defmethod make-template ((kind (eql 'regular-expression)) (spec cons))
  (make-template 'regexp spec))


(defmethod initialize-instance :after ((re-t regular-expression-template) &key)
  (destructuring-bind (re-kwd regexp &optional vars &rest keys)
      (template-spec re-t)
    (declare (ignore re-kwd))
    (multiple-value-bind (scanner reg-names)
        (let ((cl-ppcre:*allow-named-registers* t))
          (apply #'cl-ppcre:create-scanner regexp keys))
      (declare (ignorable reg-names))
      (setf (slot-value re-t 'scanner)
            scanner

            (slot-value re-t 'regexp)
            regexp

            (slot-value re-t 'vars)
            vars ; Maybe will merge with REG-NAMES...
            )
      )))

#|
(defmethod initialize-instance :after ((re-t regular-expression-template) &key)
  ;; FIX: handling of CL-PPCRE:CREATE-SCANNER keywords.  This can be
  ;; done by using the "harier" syntax of SPEC (see above).
  (destructuring-bind (re-kwd regexp &optional vars &rest keys)
      (template-spec re-t)
    (declare (ignore re-kwd)
             (ignorable regexp vars keys))
    (multiple-value-bind (scanner reg-names)
        (let ((cl-ppcre:*allow-named-registers* t))
          (cl-ppcre:create-scanner (second (template-spec re-t))))
      (declare (ignorable reg-names))
      (setf (slot-value re-t 'scanner)
            scanner

            (slot-value re-t 'regexp)
            (second (template-spec re-t)) ; For the time being just stored and
                                          ; used for debugging.
            )
      )))
|#

;;;;---------------------------------------------------------------------------
;;;; Implementation.

;;; Unification.

(defmethod unify ((ret1 regular-expression-template)
                  (ret2 regular-expression-template)
                  &optional (env (make-empty-environment))
                  &key &allow-other-keys)
  (if (eq ret1 ret2)
      env
      ;; I could UNIFY the result of the CL-PPCRE:PARSE-STRINGs.
      (error 'unification-failure
             :format-control "Do not know how unify the two ~
                              regular-expression templates: ~S and ~S."
             :format-arguments (list ret1 ret2))))


(defmethod unify ((re-t regular-expression-template) (s string)
                  &optional (env (make-empty-environment))
                  &key
                  (start 0)
                  end
                  &allow-other-keys)
  (declare (type (integer 0 #.most-positive-fixnum) start)
           (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 (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."
               :format-arguments (list s
                                       (regular-expression re-t))))
      (let ((vars (variables re-t)))
        (if (null vars)
            env
            (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)
                  finally (return result-env))))
      )))


(defmethod unify ((s string) (re-t regular-expression-template)
                  &optional (env (make-empty-environment))
                  &key (start 0) end &allow-other-keys)
  (unify re-t s env :start start :end end))
  

;;;; end of file -- cl-ppcre-template.lisp --



From mantoniotti at common-lisp.net  Wed Apr 15 10:24:28 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 06:24:28 -0400
Subject: [cl-unification-cvs] CVS cl-unification/test
Message-ID: <E1Lu2I8-0007rO-86@common-lisp.net>

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




From mantoniotti at common-lisp.net  Wed Apr 15 14:33:36 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Wed, 15 Apr 2009 10:33:36 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Lu6BE-0000kk-6S@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
ChangeLog updated.


--- /project/cl-unification/cvsroot/cl-unification/ChangeLog	2008/07/13 13:36:42	1.5
+++ /project/cl-unification/cvsroot/cl-unification/ChangeLog	2009/04/15 14:33:35	1.6
@@ -1,3 +1,85 @@
+2009-04-15  author  <author at paniscia.pd.disco.unimib.it>
+
+	* lib-dependent/cl-ppcre-template.lisp, test/unification-tests.lisp:
+	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.
+
+	* templates-hierarchy.lisp: Added LAMBDA-TEMPLATE.
+
+	* substitutions.lisp:
+	Added some functionality to extract all variables and/or all values
+	from an environment or a frame.
+
+	* match-block.lisp:
+	Added MATCHF (whose name may change) to simplify the
+	'destructuring-bind'-like syntax and behavior of the matching
+	facilities.
+
+	* COPYING: Dates updated.
+
+	* unifier.lisp:
+	Major API change to 'unify'.  It now accepts keywords.  Old code
+	shouls not be affected, but new code is now more flexible.  Look the
+	the STRING and (new) CHARACTER methods to see how this change is
+	affecting the code.
+
+	* variables.lisp: Some 'diff' unfathomable change happened.
+
+	* unification-package.lisp: Added exports of a few symbols.
+
+	* cl-unification.system, cl-unification.asd:
+	Fixed a few snags and added "lib-dependent" module.
+
+	* apply-substitution.lisp: Added some functionality and comments.
+
+2008-07-13  author  <author at paniscia.pd.disco.unimib.it>
+
+	* ChangeLog: Changelog updated.
+
+	* ACKNOWLEDGEMENTS:
+	Added credits to a few people.   Missing ones should bug the maintainer :)
+
+	* README: Copyright dates updated.
+
+	* unification.asd, unification.system: Cleaning up.
+	Committing in .
+
+	Removed Files:
+	 	unification.asd unification.system
+
+	* templates-hierarchy-saved.lisp: Clenaing up.
+	Committing in .
+
+	Removed Files:
+	 	templates-hierarchy-saved.lisp
+
+	* INSTALLATION: Instructions updated.
+
+	* COPYING: Copyright dates updated.
+
+	* test/unification-tests.lisp: Added file.
+
+	* substitutions.lisp, templates-hierarchy.lisp, unification-package.lisp, variables.lisp:
+	Some modification added.  Exported symbols and reverted
+	reader macro #T to construct template instances at read time.
+	Added MAKE-LOAD-FORM method for templates which should fix problem with
+	SBCL.
+
+	Committing in .
+
+	 Modified Files:
+	 	substitutions.lisp templates-hierarchy.lisp
+	 	unification-package.lisp variables.lisp
+
+	* cl-unification.system:
+	Added explicit :source-extension to accomodate Allegro CL.
+
 2008-07-13  author  <author at Macintosh.local>
 
 	* ACKNOWLEDGEMENTS:




From mantoniotti at common-lisp.net  Fri Apr 17 07:52:25 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Fri, 17 Apr 2009 03:52:25 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Luis5-0004yQ-BH@common-lisp.net>

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

Modified Files:
	apply-substitution.lisp 
Log Message:
Fixed a couple of snags.  APPLY-SUBSTITUTION was not applied
recursively and it was barfing on numbers.
Current version is still incomplete, but it serves as a template for
further development.


--- /project/cl-unification/cvsroot/cl-unification/apply-substitution.lisp	2009/04/15 10:05:58	1.3
+++ /project/cl-unification/cvsroot/cl-unification/apply-substitution.lisp	2009/04/17 07:52:25	1.4
@@ -17,6 +17,11 @@
 (defgeneric apply-substitution (substitution item &optional exclude-vars))
 
 
+(defmethod apply-substitution ((s environment) (n number) &optional exclude-vars)
+  (declare (ignore exclude-vars))
+  n)
+
+
 (defmethod apply-substitution ((substitution environment) (s symbol)
                                &optional (exclude-vars ()))
   (declare (type list exclude-vars))
@@ -26,7 +31,7 @@
              s
              (multiple-value-bind (val foundp)
                  (find-variable-value s substitution)
-               (cond (foundp val)
+               (cond (foundp (apply-substitution substitution val exclude-vars))
                      (t (warn "~S is a free variable in the current environment."
                               s)
                         s))))




From mantoniotti at common-lisp.net  Fri Apr 17 07:53:58 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Fri, 17 Apr 2009 03:53:58 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Luita-0004zH-MB@common-lisp.net>

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

Modified Files:
	unification-package.lisp 
Log Message:
Added a few exports and changed the actual package name (i.e., I put
my money where my mouth is; the "published" package name is now a
nickname).


--- /project/cl-unification/cvsroot/cl-unification/unification-package.lisp	2009/04/15 10:10:25	1.5
+++ /project/cl-unification/cvsroot/cl-unification/unification-package.lisp	2009/04/17 07:53:58	1.6
@@ -1,7 +1,14 @@
-;;; -*- Mode: Lisp -*-
+;;;; -*- Mode: Lisp -*-
 
-(defpackage "CL.EXT.DACF.UNIFICATION" (:use "CL")
-  (:nicknames "UNIFY")
+;;;; unification-package.lisp --
+;;;; Package definition for the CL-UNIFICATION library.
+;;;;
+;;;; Copyright (c) 2004-2009 Marco Antoniotti
+;;;; See file COPYING for licensing information.
+
+
+(defpackage "IT.UNIMIB.DISCO.MA.CL.EXT.DACF.UNIFICATION" (:use "CL")
+  (:nicknames  "CL.EXT.DACF.UNIFICATION" "UNIFY" "unify")
   (:documentation "The CL.EXT.DACF.UNIFICATION Package.
 
 This package contains all the definitions necessary for the general
@@ -40,6 +47,11 @@
    "UNIFY*"
    "UNIFY-EQUATIONS"
    "UNIFY-EQUATIONS*")
+
+  #+cl-ppcre
+  (:export
+   "REGULAR-EXPRESSION"
+   "REGEXP")
   )
 
-;;; end of file -- unification-package.lisp --
+;;;; end of file -- unification-package.lisp --




From mantoniotti at common-lisp.net  Fri Apr 17 22:39:06 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Fri, 17 Apr 2009 18:39:06 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1LuwiA-0006tD-Ri@common-lisp.net>

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

Added Files:
	cl-unification-lib.asd 
Log Message:
File added.



--- /project/cl-unification/cvsroot/cl-unification/cl-unification-lib.asd	2009/04/17 22:39:06	NONE
+++ /project/cl-unification/cvsroot/cl-unification/cl-unification-lib.asd	2009/04/17 22:39:06	1.1
;;;; -*- Mode: Lisp -*-

;;;; cl-unification-lib.asd --
;;;; ASDF system file.

(asdf:defsystem :cl-unification-lib
  :author "Marco Antoniotti"
  :components ((:module "lib-dependent"
                :components ((:file "cl-ppcre-template"))))
  :depends-on (cl-ppcre cl-unification))

;;;; end of file -- cl-unification-lib.asd --



From mantoniotti at common-lisp.net  Fri Apr 17 22:40:29 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Fri, 17 Apr 2009 18:40:29 -0400
Subject: [cl-unification-cvs] CVS cl-unification/lib-dependent
Message-ID: <E1LuwjV-0007O9-Tf@common-lisp.net>

Update of /project/cl-unification/cvsroot/cl-unification/lib-dependent
In directory cl-net:/tmp/cvs-serv28352

Modified Files:
	cl-ppcre-template.lisp 
Log Message:
Removed REQUIRE of CL-PPCRE.  Too brittle.


--- /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.lisp	2009/04/15 10:24:28	1.1
+++ /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.lisp	2009/04/17 22:40:29	1.2
@@ -5,8 +5,6 @@
 
 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
 
-(require "CL-PPCRE")
-
 
 ;;;; REGEXP Templates.
 ;;;; Another extension of the type specifier language.




From mantoniotti at common-lisp.net  Fri Apr 17 22:41:34 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Fri, 17 Apr 2009 18:41:34 -0400
Subject: [cl-unification-cvs] CVS cl-unification/lib-dependent
Message-ID: <E1LuwkY-0007Uk-N2@common-lisp.net>

Update of /project/cl-unification/cvsroot/cl-unification/lib-dependent
In directory cl-net:/tmp/cvs-serv28811

Added Files:
	cl-ppcre-template.system 
Log Message:
File added.



--- /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.system	2009/04/17 22:41:34	NONE
+++ /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.system	2009/04/17 22:41:34	1.1
;;;; -*- Mode: Lisp -*-

;;;; cl-ppcre-template.system --
;;;; MK system file.

(mk:defsystem "CL-PPCRE-TEMPLATE"
  :author "Marco Antoniotti"
  :non-required-p t
  :components ((:file "cl-ppcre-template"))
  :depends-on ("CL-PPCRE"))

;;;; end of file -- cl-ppcre-template.system --



From mantoniotti at common-lisp.net  Fri Apr 17 22:42:46 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Fri, 17 Apr 2009 18:42:46 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Luwli-0007VZ-PG@common-lisp.net>

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

Modified Files:
	cl-unification.asd 
Log Message:
System definitions files (.asd and .system) modified in order to make
dependency form CL-PPCRE optional.


--- /project/cl-unification/cvsroot/cl-unification/cl-unification.asd	2009/04/15 10:06:40	1.2
+++ /project/cl-unification/cvsroot/cl-unification/cl-unification.asd	2009/04/17 22:42:46	1.3
@@ -3,22 +3,38 @@
 ;;;; cl-unification.asd --
 ;;;; ASDF system file.
 
-(asdf:defsystem cl-unification
-		:author "Marco Antoniotti"
-		:serial t
-		:components ((:file "unification-package")
-			     (:file "variables")
-			     (:file "substitutions")
-			     (:file "lambda-list-parsing")
-			     (:file "templates-hierarchy")
-			     (:file "unifier")
-			     (:file "match-block")
-			     (:file "apply-substitution")
-                             (:module "lib-dependent"
-                              :depends-on ("templates-hierarchy" "unifier")
-                              :components (
-                                           #+cl-ppcre
-                                           (:file "cl-ppcre-template")
-                                           ))))
+;;;;===========================================================================
+;;;; Simple stuff that should be built in ASDF.
+
+(defpackage "CL-UNIFICATION-SYSTEM" (:use "CL" "ASDF"))
+
+(in-package "CL-UNIFICATION-SYSTEM")
+
+(defclass asdf-system-definition-file (asdf:cl-source-file) ())
+(defmethod source-file-type ((c asdf-system-definition-file) (s module)) "asd")
+
+
+(asdf:defsystem :cl-unification
+  :author "Marco Antoniotti"
+  :serial t
+  :components ((:file "unification-package")
+               (:file "variables")
+               (:file "substitutions")
+               (:file "lambda-list-parsing")
+               (:file "templates-hierarchy")
+               (:file "unifier")
+               (:file "match-block")
+               (:file "apply-substitution")
+               #+asdf-with-optional-dependencies
+               (:module "lib-dependent"
+                :pathname "lib-dependent"
+                :depends-on ("templates-hierarchy" "unifier")
+                :components ((:file "cl-ppcre-template"
+                              :depends-on (cl-ppcre))
+                             ))
+               #-asdf-with-optional-dependencies
+               (asdf-system-definition-file
+                "cl-unification-lib")
+               ))
 
 ;;;; end of file -- cl-unification.asd --




From mantoniotti at common-lisp.net  Fri Apr 17 22:42:50 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Fri, 17 Apr 2009 18:42:50 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1Luwlm-0007W2-8A@common-lisp.net>

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

Modified Files:
	cl-unification.system 
Log Message:
System definitions files (.asd and .system) modified in order to make
dependency form CL-PPCRE optional.


--- /project/cl-unification/cvsroot/cl-unification/cl-unification.system	2009/04/15 10:09:43	1.3
+++ /project/cl-unification/cvsroot/cl-unification/cl-unification.system	2009/04/17 22:42:50	1.4
@@ -4,21 +4,21 @@
 ;;;; MK:DEFSYSTEM system file.
 
 (mk:defsystem "CL-UNIFICATION"
-    :source-extension "lisp"
-    :components ("unification-package"
-		 "variables"
-		 "substitutions"
-		 "lambda-list-parsing"
-		 "templates-hierarchy"
-		 "unifier"
-		 "match-block"
-		 "apply-substitution"
-                 (:module "lib-dependent"
-                  :depends-on ("templates-hierarchy" "unifier")
-                  :components (
-                               #+cl-ppcre
-                               (:file "cl-ppcre-template")
-                               ))
-                 ))
+  :source-extension "lisp"
+  :components ("unification-package"
+               "variables"
+               "substitutions"
+               "lambda-list-parsing"
+               "templates-hierarchy"
+               "unifier"
+               "match-block"
+               "apply-substitution"
+               (:module "lib-dependent"
+                :depends-on ("templates-hierarchy" "unifier")
+                :components ((:subsystem "cl-ppcre-template"
+                              :non-required-p t
+                              )
+                             ))
+               ))
    
 ;;; end of file -- cl-unification.system --




From mantoniotti at common-lisp.net  Fri Apr 17 22:44:17 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Fri, 17 Apr 2009 18:44:17 -0400
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1LuwnB-0007XB-AL@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
ChangeLog updated.


--- /project/cl-unification/cvsroot/cl-unification/ChangeLog	2009/04/15 14:33:35	1.6
+++ /project/cl-unification/cvsroot/cl-unification/ChangeLog	2009/04/17 22:44:17	1.7
@@ -1,3 +1,71 @@
+2009-04-18  author  <author at Macintosh-9.local>
+
+	* cl-unification.system, cl-unification.asd:
+	System definitions files (.asd and .system) modified in order to make
+	dependency form CL-PPCRE optional.
+
+	* lib-dependent/cl-ppcre-template.system: File added.
+
+	* lib-dependent/cl-ppcre-template.lisp:
+	Removed REQUIRE of CL-PPCRE.  Too brittle.
+
+	* cl-unification-lib.asd: File added.
+
+2009-04-17  author  <author at Macintosh-9.local>
+
+	* unification-package.lisp:
+	Added a few exports and changed the actual package name (i.e., I put
+	my money where my mouth is; the "published" package name is now a
+	nickname).
+
+	* apply-substitution.lisp:
+	Fixed a couple of snags.  APPLY-SUBSTITUTION was not applied
+	recursively and it was barfing on numbers.
+	Current version is still incomplete, but it serves as a template for
+	further development.
+
+2009-04-15  author  <author at Macintosh-9.local>
+
+	* ChangeLog: ChangeLog updated.
+
+	* lib-dependent/cl-ppcre-template.lisp, test/unification-tests.lisp:
+	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.
+
+	* templates-hierarchy.lisp: Added LAMBDA-TEMPLATE.
+
+	* substitutions.lisp:
+	Added some functionality to extract all variables and/or all values
+	from an environment or a frame.
+
+	* match-block.lisp:
+	Added MATCHF (whose name may change) to simplify the
+	'destructuring-bind'-like syntax and behavior of the matching
+	facilities.
+
+	* COPYING: Dates updated.
+
+	* unifier.lisp:
+	Major API change to 'unify'.  It now accepts keywords.  Old code
+	shouls not be affected, but new code is now more flexible.  Look the
+	the STRING and (new) CHARACTER methods to see how this change is
+	affecting the code.
+
+	* variables.lisp: Some 'diff' unfathomable change happened.
+
+	* unification-package.lisp: Added exports of a few symbols.
+
+	* cl-unification.system, cl-unification.asd:
+	Fixed a few snags and added "lib-dependent" module.
+
+	* apply-substitution.lisp: Added some functionality and comments.
+
 2009-04-15  author  <author at paniscia.pd.disco.unimib.it>
 
 	* lib-dependent/cl-ppcre-template.lisp, test/unification-tests.lisp: