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