Fri Jan 15 08:55:05 UTC 2010 pix@kepibu.org

* Redefine MATCH-CASE in terms of MATCHING

This both greatly simplifies the MATCH-CASE macro as well as its expansion.

HOWEVER, this version is *NOT* 100% compatible with the previous version.

Specifically, UNIFICATION-FAILUREs signalled from within clause-forms will /not/

cause the next unification clause to be attempted, but will instead propogate

outward as the -case name suggests they should.

That is,

(ignore-errors

(match-case ("foo")

("foo" (error 'unification-failure ...))

(t :default)))

=> :default ;; before patch

=> nil, #<unification-failure> ;; after patch

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

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

@@ -209,16 +209,6 @@

))

-;;; match-case --

-;;; Implementation provided by Peter Scott.

-;;;

-;;; Notes:

-;;;

-;;; [MA 20071109]

-;;; 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 match-case-named)

&body clauses)

"MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.

@@ -248,33 +238,16 @@

any default clause. Otherwise, the default clause behaves as a

standard CASE default clause. The default value of ERRORP is NIL.

"

- (declare (ignore default-substitution)) ; For the time being.

- (let* ((object-var (gensym "OBJECT-VAR-"))

- (otherwise-clause-present-p

- (member (caar (last clauses)) '(t otherwise)))

- (non-otherwise-clauses

- (if otherwise-clause-present-p

- (butlast clauses)

- clauses))

- (otherwise-clause

- (if otherwise-clause-present-p

- (first (last clauses))

- (when errorp

- `(t (error 'unification-non-exhaustive

- :format-control "Non exhaustive matching.")))))

- )

- (labels ((generate-matchers (clauses)

- (if (null clauses)

- `(progn ,@(rest otherwise-clause))

- (destructuring-bind (pattern &rest body)

- (car clauses)

- `(handler-case (match (,pattern ,object-var)

- ,@body)

- (unification-failure ()

- ,(generate-matchers (cdr clauses))))))))

- `(block ,match-case-named

- (let ((,object-var ,object))

- ,(generate-matchers non-otherwise-clauses))))))

+ (let ((object-var (gensym "OBJECT-VAR-")))

+ `(let ((,object-var ,object))

+ (matching (:errorp ,errorp :default-substitution ,default-substitution :matching-named ,match-case-named)

+ ,@(mapcar

+ (lambda (clause)

+ `(,(if (member (first clause) '(t otherwise))

+ (first clause)

+ (list (first clause) object-var))

+ ,@(rest clause)))

+ clauses)))))

(defmacro matchf-case ((object &key errorp default-substitution match-case-named)