Tue Oct 25 19:08:15 UTC 2005 mantoniotti

* Fixed problem with checking the presence of T and OTHERWISE clauses in

Fixed problem with checking the presence of T and OTHERWISE clauses in

MATCHING.

--- old-cl-unification-1/match-block.lisp 2013-07-21 19:59:38.000000000 +0000

+++ new-cl-unification-1/match-block.lisp 2013-07-21 19:59:38.000000000 +0000

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