[cl-unification-cvs] CVS update: cl-unification/match-block.lisp

[Marco Antoniotti]

Update of /project/cl-unification/cvsroot/cl-unification
In directory common-lisp.net:/tmp/cvs-serv4395

Modified Files:
	match-block.lisp 
Log Message:
Fixed problem with checking the presence of T and OTHERWISE clauses in
MATCHING.

Date: Tue Oct 25 21:08:15 2005
Author: mantoniotti

Index: cl-unification/match-block.lisp
diff -u cl-unification/match-block.lisp:1.5 cl-unification/match-block.lisp:1.6
--- cl-unification/match-block.lisp:1.5	Wed Apr 27 23:04:36 2005
+++ cl-unification/match-block.lisp	Tue Oct 25 21:08:15 2005
@@ -93,11 +93,15 @@
              (let ((template-vars (collect-template-vars template)))
                (flet ((generate-var-bindings ()
                         (loop for v in template-vars
-                              nconc (list `(,v (find-variable-value ',v ,clause-var))
+                              nconc (list `(,v (find-variable-value
+						',v
+						,clause-var))
                                           `(,(clean-unify-var-name v) ,v))))
                       )
                  `((setf ,clause-var
-                         (ignore-errors (unify ',template ,object ,substitution)))
+                         (ignore-errors (unify ',template
+					       ,object
+					       ,substitution)))
                    (let* (,@(generate-var-bindings))
                      , at forms))
                  )))
@@ -105,10 +109,16 @@
            (build-match-clause (match-clause match-env-var)
              (destructuring-bind ((template object) &body forms)
                  match-clause
-               (%%match%% match-env-var template object forms '(make-empty-environment))))
+               (%%match%% match-env-var
+			  template
+			  object
+			  forms
+			  '(make-empty-environment))))
            )
-    (when (or (> 1 (count t match-clauses :key #'first))
-              (> 1 (count 'otherwise match-clauses :key #'first)))
+    (when (or (and (find t match-clauses :key #'first)
+		   (find 'otherwise match-clauses :key #'first))
+	      (> (count t match-clauses :key #'first) 1)
+              (> (count 'otherwise match-clauses :key #'first) 1))
       (error 'program-error))
     (let* ((default-clause (or (find t match-clauses :key #'first)
                                (find 'otherwise match-clauses :key #'first)))