[cl-unification-cvs] CVS update: cl-unification/match-block.lisp

[Marco Antoniotti]

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)
+				      , at body)
+		        (unification-failure ()
+			                     ,(generate-matchers (cdr clauses))))))))
+      `(let ((,object-var ,object))
+	 ,(generate-matchers non-otherwise-clauses)))))
+
+
 ;;; end of file -- math-blocks.lisp --