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.
diff -rN -u old-cl-unification-1/match-block.lisp new-cl-unification-1/match-block.lisp
--- old-cl-unification-1/match-block.lisp 2013-07-21 19:57:06.000000000 +0000
+++ new-cl-unification-1/match-block.lisp 2013-07-21 19:57:06.000000000 +0000
@@ -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 --