[cl-unification-cvs] CVS cl-unification

[mantoniotti]

Update of /project/cl-unification/cvsroot/cl-unification
In directory cl-net:/tmp/cvs-serv27397

Modified Files:
	match-block.lisp 
Log Message:
Added MATCHF (whose name may change) to simplify the
'destructuring-bind'-like syntax and behavior of the matching
facilities.


--- /project/cl-unification/cvsroot/cl-unification/match-block.lisp	2007/11/09 13:43:20	1.8
+++ /project/cl-unification/cvsroot/cl-unification/match-block.lisp	2009/04/15 10:16:24	1.9
@@ -13,6 +13,7 @@
 
 (defmacro match ((template object
                            &key
+                           (match-named nil)
                            (substitution '(make-empty-environment))
                            (errorp t)
                            (error-value nil))
@@ -32,6 +33,9 @@
 whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
 raising from the evaluation of FORMS will also be caught and handled
 according to ERRORP settings.)
+
+If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
+is set up around the matching code.
 "
   (let ((template-vars (collect-template-vars template))
         (env-var (gensym "UNIFICATION-ENV-"))
@@ -45,7 +49,73 @@
                                                          ,env-var))
                                `(,(clean-unify-var-name v) ,v))))
            )
-      `(block nil
+      `(block ,match-named
+         (handler-case
+             (let* ((,env-var (unify ,template ,object ,substitution))
+                    ,@(generate-var-bindings)
+                    )
+	       (declare (ignorable ,@(mapcar #'first
+                                             (generate-var-bindings))))
+               , at forms)
+           
+           ;; Yes.  The above is sligthly wasteful.
+
+           (unification-failure (uf)
+                                (if ,errorp
+                                    (error uf)
+                                    ,error-value))
+           )))))
+
+
+(defmacro matchf ((template object
+                            &key
+                            (match-named nil)
+                            (substitution '(make-empty-environment))
+                            (errorp t)
+                            (error-value nil))
+                  &body forms)
+  "Sets up a lexical environment to evaluate FORMS after an unification.
+
+MATCHF unifies a TEMPLATE and an OBJECT and then sets up a lexical
+environment where the variables present in the template are bound
+lexically.  Note that both variable names '?FOO' and 'FOO' are bound
+for convenience.
+
+MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will
+generate a template at read-time).
+
+The MATCHF form returns the values returned by the evaluation of the
+last of the FORMS.
+
+If ERRORP is non-NIL (the default) then the form raises a
+UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
+whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
+raising from the evaluation of FORMS will also be caught and handled
+according to ERRORP settings.)
+
+If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
+is set up around the matching code.
+"
+  (let ((template-vars (collect-template-vars template))
+        (env-var (gensym "UNIFICATION-ENV-"))
+        (template (cond ((variablep template)
+                         `',template) ; Logical variables are special-cased.
+                        ((listp template) ; Same for lists.
+                         (make-instance 'list-template
+                                        :spec (cons 'list template)))
+                        ;`',template)
+                        (t
+                         template)))
+        )
+    ;; Logical variables and lists are special cased for convenience.
+    ;; Lists are especially inteded as abbreviation for destructuring.
+    (flet ((generate-var-bindings ()
+             (loop for v in template-vars
+                   nconc (list `(,v (find-variable-value ',v
+                                                         ,env-var))
+                               `(,(clean-unify-var-name v) ,v))))
+           )
+      `(block ,match-named
          (handler-case
              (let* ((,env-var (unify ,template ,object ,substitution))
                     ,@(generate-var-bindings)
@@ -70,7 +140,8 @@
 
 (defmacro matching ((&key errorp
                           (default-substitution
-                           (make-empty-environment)))
+                           (make-empty-environment))
+                          (matching-named nil))
                     &rest match-clauses)
   "MATCHING sets up a COND-like environment for multiple template matching clauses.
 
@@ -150,7 +221,7 @@
                                            match-clauses))
            )
 
-      `(block matching
+      `(block ,matching-named
          (let ,match-clauses-env-vars
 	   (declare (dynamic-extent , at match-clauses-env-vars))
            (cond ,@(mapcar (lambda (match-clause match-clause-env-var)
@@ -171,11 +242,11 @@
 ;;; Notes:
 ;;;
 ;;; [MA 20071109]
-;;; When the construction of the inner MATCH clauses could be done
+;;; The construction of the inner MATCH clauses could be done
 ;;; more intelligently by supplying :ERRORP NIL, thus avoiding the
 ;;; HANDLER-CASEs, which are quite expensive.  Any takers?
 
-(defmacro match-case ((object &key errorp default-substitution)
+(defmacro match-case ((object &key errorp default-substitution match-case-named)
                       &rest clauses)
   "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.
 
@@ -227,9 +298,10 @@
 		     `(handler-case (match (,pattern ,object-var)
 				      , at body)
 		        (unification-failure ()
-			                     ,(generate-matchers (cdr clauses))))))))
-      `(let ((,object-var ,object))
-	 ,(generate-matchers non-otherwise-clauses)))))
+			  ,(generate-matchers (cdr clauses))))))))
+      `(block ,match-case-named
+         (let ((,object-var ,object))
+           ,(generate-matchers non-otherwise-clauses))))))
 
 ;;;;---------------------------------------------------------------------------
 ;;;; Testing.