Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv18479
Modified Files: match-block.lisp Log Message: Added MATCHF* macros.
--- /project/cl-unification/cvsroot/cl-unification/match-block.lisp 2009/04/15 10:16:24 1.9 +++ /project/cl-unification/cvsroot/cl-unification/match-block.lisp 2009/12/17 16:41:38 1.10 @@ -303,6 +303,68 @@ (let ((,object-var ,object)) ,(generate-matchers non-otherwise-clauses))))))
+ +(defmacro matchf-case ((object &key errorp default-substitution match-case-named) + &rest clauses) + "MATCHF-CASE sets up a CASE-like environment for multiple template matching clauses. + +The syntax of MATCHF-CASE comprises a number of clauses of the form + + <clause> ::= <regular-clause> | <default-clause> + <regular-clause> ::= (<template> &body <forms>) + <default-clause> ::= (t &body <forms>) + | (otherwise &body <forms>) +<form> and <forms> are regular Common Lisp forms. +<template> is a unification template. + +The full syntax of MATCHF-CASE is + + matchf-case <object> (&key errorp default-substitution) <clauses> + +Each clause evaluates its forms in an environment where the variables +present in the template are bound lexically. Note that both variable +names '?FOO' and 'FOO' are bound for convenience. + +The values returned by the MATCH-CASE form are those of the last form in +the first clause that satisfies the match test. + +If ERRORP is non-NIL then if none of the regular clauses matches, then +an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of +any default clause. Otherwise, the default clause behaves as a +standard CASE default clause. The default value of ERRORP is NIL. + +MATCHF-CASE behaves like MATCH-CASE, but the patterns are not +evaluated (i.e., it relies on MATCHF instead of MATCH to construct the +macro expansion. +" + (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 (matchf (,pattern ,object-var) + ,@body) + (unification-failure () + ,(generate-matchers (cdr clauses)))))))) + `(block ,match-case-named + (let ((,object-var ,object)) + ,(generate-matchers non-otherwise-clauses)))))) + ;;;;--------------------------------------------------------------------------- ;;;; Testing.