Thu Dec 17 16:41:38 UTC 2009 mantoniotti
* Added MATCHF* macros.
hunk ./match-block.lisp 306
+[_^M_][_$_]
+(defmacro matchf-case ((object &key errorp default-substitution match-case-named)[_^M_][_$_]
+ &rest clauses)[_^M_][_$_]
+ "MATCHF-CASE sets up a CASE-like environment for multiple template matching clauses.[_^M_][_$_]
+[_^M_][_$_]
+The syntax of MATCHF-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 MATCHF-CASE is[_^M_][_$_]
+[_^M_][_$_]
+ matchf-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 MATCH-CASE 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_][_$_]
+MATCHF-CASE behaves like MATCH-CASE, but the patterns are not[_^M_][_$_]
+evaluated (i.e., it relies on MATCHF instead of MATCH to construct the[_^M_][_$_]
+macro expansion.[_^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_][_$_]
+ `(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 (matchf (,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_][_$_]
+[_^M_][_$_]