Update of /project/cl-unification/cvsroot/cl-unification In directory common-lisp.net:/tmp/cvs-serv23912

Modified Files: match-block.lisp Log Message: Added MATCH-CASE macro. Slightly modified from the version provided by Peter Scott.

Date: Wed Apr 27 22:41:56 2005 Author: mantoniotti

Index: cl-unification/match-block.lisp diff -u cl-unification/match-block.lisp:1.1.1.1 cl-unification/match-block.lisp:1.2 --- cl-unification/match-block.lisp:1.1.1.1 Wed Nov 17 23:19:54 2004 +++ cl-unification/match-block.lisp Wed Apr 27 22:41:56 2005 @@ -126,4 +126,59 @@ ))

+ +(defmacro match-case ((object &key errorp default-substitution) &rest clauses) + "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses. +The syntax of MATCH-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 MATCHING is + + match-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 MATCHING 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. +" + (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 + `(error 'unification-not-exhaustive)))) + ) + (labels ((generate-matchers (clauses) + (if (null clauses) + otherwise-clause + (destructuring-bind (pattern &rest body) + (car clauses) + `(handler-case (match (,pattern ,object-var) + ,@body) + (unification-failure () + ,(generate-matchers (cdr clauses)))))))) + `(let ((,object-var ,object)) + ,(generate-matchers non-otherwise-clauses))))) + + ;;; end of file -- math-blocks.lisp --