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
hunk ./match-block.lisp 212
-;;; match-case --[_^M_][_$_]
-;;; Implementation provided by Peter Scott.[_^M_][_$_]
-;;;[_^M_][_$_]
-;;; Notes:[_^M_][_$_]
-;;;[_^M_][_$_]
-;;; [MA 20071109][_^M_][_$_]
-;;; The construction of the inner MATCH clauses could be done[_^M_][_$_]
-;;; more intelligently by supplying :ERRORP NIL, thus avoiding the[_^M_][_$_]
-;;; HANDLER-CASEs, which are quite expensive. Any takers?[_^M_][_$_]
-[_^M_][_$_]
hunk ./match-block.lisp 241
- (declare (ignore default-substitution)) ; For the time being.[_^M_][_$_]
- (let* ((object-var (gensym "OBJECT-VAR-"))[_^M_][_$_]
- (otherwise-clause-present-p[_^M_][_$_]
- (member (caar (last clauses)) '(t otherwise)))[_^M_][_$_]
- (non-otherwise-clauses[_^M_][_$_]
- (if otherwise-clause-present-p[_^M_][_$_]
- (butlast clauses)[_^M_][_$_]
- clauses))[_^M_][_$_]
- (otherwise-clause[_^M_][_$_]
- (if otherwise-clause-present-p[_^M_][_$_]
- (first (last clauses))[_^M_][_$_]
- (when errorp[_^M_][_$_]
- `(t (error 'unification-non-exhaustive[_^M_][_$_]
- :format-control "Non exhaustive matching.")))))[_^M_][_$_]
- )[_^M_][_$_]
- (labels ((generate-matchers (clauses)[_^M_][_$_]
- (if (null clauses)[_^M_][_$_]
- `(progn ,@(rest otherwise-clause))[_^M_][_$_]
- (destructuring-bind (pattern &rest body)[_^M_][_$_]
- (car clauses)[_^M_][_$_]
- `(handler-case (match (,pattern ,object-var)[_^M_][_$_]
- ,@body)[_^M_][_$_]
- (unification-failure ()[_^M_][_$_]
- ,(generate-matchers (cdr clauses))))))))[_^M_][_$_]
- `(block ,match-case-named[_^M_][_$_]
- (let ((,object-var ,object))[_^M_][_$_]
- ,(generate-matchers non-otherwise-clauses))))))[_^M_][_$_]
+ (let ((object-var (gensym "OBJECT-VAR-")))[_^M_][_$_]
+ `(let ((,object-var ,object))[_^M_][_$_]
+ (matching (:errorp ,errorp :default-substitution ,default-substitution :matching-named ,match-case-named)[_^M_][_$_]
+ ,@(mapcar[_^M_][_$_]
+ (lambda (clause)[_^M_][_$_]
+ `(,(if (member (first clause) '(t otherwise))[_^M_][_$_]
+ (first clause)[_^M_][_$_]
+ (list (first clause) object-var))[_^M_][_$_]
+ ,@(rest clause)))[_^M_][_$_]
+ clauses)))))[_^M_][_$_]