Mon May 21 12:33:05 UTC 2007  mantoniotti
  * See previous message.
diff -rN -u old-cl-unification-1/apply-substitution.lisp new-cl-unification-1/apply-substitution.lisp
--- old-cl-unification-1/apply-substitution.lisp	2013-07-24 17:40:51.000000000 +0000
+++ new-cl-unification-1/apply-substitution.lisp	2013-07-24 17:40:51.000000000 +0000
@@ -9,72 +9,29 @@
 ;;;---------------------------------------------------------------------------
 ;;; Substitution application.
 
-;;; apply-substitution --
-;;;
-;;; EXCLUDE-VARS are variables that will just pass through (a list for
-;;; the time being).
+(defgeneric apply-substitution (substitution item))
 
-(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))
+(defmethod apply-substitution ((substitution environment) (s symbol))
   (cond ((variable-any-p s) s)
         ((variablep s)
-         (if (member s exclude-vars :test #'eq)
-             s
-             (multiple-value-bind (val foundp)
-                 (find-variable-value s substitution)
-               (cond (foundp (apply-substitution substitution val exclude-vars))
-                     (t (warn "~S is a free variable in the current environment."
-                              s)
-                        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)
-                               &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 cons))
+  (cons (apply-substitution substitution (first l))
+        (apply-substitution substitution (rest l))))
 
-
-(defmethod apply-substitution ((substitution environment) (l null)
-                               &optional exclude-vars)
-  (declare (ignore exclude-vars))
+(defmethod apply-substitution ((substitution environment) (l null))
   '())
 
+(export '(apply-substitution))
 
-;;; 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))
diff -rN -u old-cl-unification-1/match-block.lisp new-cl-unification-1/match-block.lisp
--- old-cl-unification-1/match-block.lisp	2013-07-24 17:40:51.000000000 +0000
+++ new-cl-unification-1/match-block.lisp	2013-07-24 17:40:51.000000000 +0000
@@ -10,7 +10,7 @@
 
 (defmacro match ((template object
                            &key
-                           (substitution (make-empty-environment))
+                           (substitution '(make-empty-environment))
                            (errorp t)
                            (error-value nil))
                  &body forms)
@@ -39,7 +39,7 @@
            )
       `(block nil
          (handler-case
-             (let* ((,env-var (unify ',template ,object ,substitution))
+             (let* ((,env-var (unify ,template ,object ,substitution))
                     ,@(generate-var-bindings)
                     )
 	       (declare (ignorable ,@(mapcar #'first (generate-var-bindings))))
@@ -49,7 +49,7 @@
 
            (unification-failure (uf)
                                 (if ,errorp
-                                    (signal uf)
+                                    (error uf)
                                     ,error-value))
            )))))
 
@@ -155,7 +155,7 @@
 <form> and <forms> are regular Common Lisp forms.
 <template> is a unification template.
 
-The full syntax of MATCHING is
+The full syntax of MATCH-CASE is
 
   match-case <object> (&key errorp default-substitution) <clauses>
 
@@ -163,7 +163,7 @@
 present in the template are bound lexically.  Note that both variable
 names '?FOO' and 'FOO' are bound for convenience.
 
-The values returned by the MATCHING form are those of the last form in
+The values returned by the MATCH-CASE form are those of the last form in
 the first clause that satisfies the match test.
 
 If ERRORP is non-NIL then if none of the regular clauses matches, then
@@ -188,7 +188,7 @@
          )
     (labels ((generate-matchers (clauses)
 	       (if (null clauses)
-		   otherwise-clause
+		   `(progn ,@(rest otherwise-clause))
 		   (destructuring-bind (pattern &rest body)
 		       (car clauses)
 		     `(handler-case (match (,pattern ,object-var)
diff -rN -u old-cl-unification-1/substitutions.lisp new-cl-unification-1/substitutions.lisp
--- old-cl-unification-1/substitutions.lisp	2013-07-24 17:40:51.000000000 +0000
+++ new-cl-unification-1/substitutions.lisp	2013-07-24 17:40:51.000000000 +0000
@@ -24,11 +24,22 @@
   (declare (type binding b))
   (car b))
 
+(defun (setf binding-variable) (v b)
+  (declare (type binding b))
+  (setf (car b) v))
+
+
 (defun binding-value (b)
   (declare (type binding b))
   (cdr b))
 
 
+(defun (setf binding-value) (v b)
+  (declare (type binding b))
+  (setf (cdr b) v))
+
+
+
 (define-condition unification-variable-unbound (unbound-variable)
   ()
   )
diff -rN -u old-cl-unification-1/unification-package.lisp new-cl-unification-1/unification-package.lisp
--- old-cl-unification-1/unification-package.lisp	2013-07-24 17:40:51.000000000 +0000
+++ new-cl-unification-1/unification-package.lisp	2013-07-24 17:40:51.000000000 +0000
@@ -14,7 +14,8 @@
    "*UNIFY-STRING-CASE-INSENSITIVE-P*"
    "UNIFY"
    "FIND-VARIABLE-VALUE"
-   "MAKE-EMPTY-ENVIRONMENT")
+   "MAKE-EMPTY-ENVIRONMENT"
+   "APPLY-SUBSTITUTION")
   (:export
    "MATCH"
    "MATCHING"
diff -rN -u old-cl-unification-1/unification.asd new-cl-unification-1/unification.asd
--- old-cl-unification-1/unification.asd	2013-07-24 17:40:51.000000000 +0000
+++ new-cl-unification-1/unification.asd	2013-07-24 17:40:51.000000000 +0000
@@ -12,6 +12,7 @@
 			     (:file "lambda-list-parsing")
 			     (:file "templates-hierarchy")
 			     (:file "unifier")
-			     (:file "match-block")))
+			     (:file "match-block")
+			     (:file "apply-substitution")))
 
 ;;; end of file -- unification.asd --