Wed Apr 27 20:41:56 UTC 2005 mantoniotti
* Added MATCH-CASE macro. Slightly modified from the version provided
Added MATCH-CASE macro. Slightly modified from the version provided
by Peter Scott.
hunk ./match-block.lisp 129
+[_^M_][_$_]
+(defmacro match-case ((object &key errorp default-substitution) &rest clauses)[_^M_][_$_]
+ "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.[_^M_][_$_]
+The syntax of MATCH-CASE comprises a number of clauses of the form[_^M_][_$_]
+[_^M_][_$_]
+ <clause> ::= <regular-clause> | <default-clause>[_^M_][_$_]
+ <regular-clause> ::= (<template> &body <forms>)[_^M_][_$_]
+ <default-clause> ::= (t &body <forms>)[_^M_][_$_]
+ | (otherwise &body <forms>)[_^M_][_$_]
+<form> and <forms> are regular Common Lisp forms.[_^M_][_$_]
+<template> is a unification template.[_^M_][_$_]
+[_^M_][_$_]
+The full syntax of MATCHING is[_^M_][_$_]
+[_^M_][_$_]
+ match-case <object> (&key errorp default-substitution) <clauses>[_^M_][_$_]
+[_^M_][_$_]
+Each clause evaluates its forms in an environment where the variables[_^M_][_$_]
+present in the template are bound lexically. Note that both variable[_^M_][_$_]
+names '?FOO' and 'FOO' are bound for convenience.[_^M_][_$_]
+[_^M_][_$_]
+The values returned by the MATCHING form are those of the last form in[_^M_][_$_]
+the first clause that satisfies the match test.[_^M_][_$_]
+[_^M_][_$_]
+If ERRORP is non-NIL then if none of the regular clauses matches, then[_^M_][_$_]
+an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of[_^M_][_$_]
+any default clause. Otherwise, the default clause behaves as a[_^M_][_$_]
+standard CASE default clause. The default value of ERRORP is NIL.[_^M_][_$_]
+"[_^M_][_$_]
+ (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_][_$_]
+ `(error 'unification-not-exhaustive))))[_^M_][_$_]
+ )[_^M_][_$_]
+ (labels ((generate-matchers (clauses)[_^M_][_$_]
+ (if (null clauses)[_^M_][_$_]
+ 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_][_$_]
+ `(let ((,object-var ,object))[_^M_][_$_]
+ ,(generate-matchers non-otherwise-clauses)))))[_^M_][_$_]
+[_^M_][_$_]
+[_^M_][_$_]