Tue Jan 12 09:08:23 UTC 2010  pix@kepibu.org
  * Extract the bits that wrap forms with bindings for template variables
  In some cases, this patch swaps the order of execution of
  %TEMPLATE-FOR-MATCH and COLLECT-TEMPLATE-VARS.  I'm pretty sure this
  doesn't have any noticable effect, but thorough testing is probably
  wise.
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-24 17:30:30.000000000 +0000
+++ new-cl-unification-1/match-block.lisp	2013-07-24 17:30:30.000000000 +0000
@@ -15,6 +15,16 @@
       `',template ; Logical variables are special-cased.
       template))
 
+(defun %wrap-var-bindings (template environment-var forms)
+  (let* ((template-vars (collect-template-vars template))
+         (bindings (loop for v in template-vars
+                         nconc (list `(,v (find-variable-value ',v
+                                                               ,environment-var))
+                                     `(,(clean-unify-var-name v) ,v)))))
+    `(let* ,bindings
+       (declare (ignorable ,@(mapcar #'first bindings)))
+       ,@forms)))
+
 (defmacro match ((template object
                            &key
                            (match-named nil)
@@ -41,32 +51,22 @@
 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-"))
+  (let ((env-var (gensym "UNIFICATION-ENV-"))
         (template (%template-for-match template))
         )
-    (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)
-                    )
-	       (declare (ignorable ,@(mapcar #'first
-                                             (generate-var-bindings))))
-               ,@forms)
+    `(block ,match-named
+       (handler-case
+           (let* ((,env-var (unify ,template ,object ,substitution))
+                  )
+             ,(%wrap-var-bindings template env-var forms))
            
-           ;; Yes.  The above is sligthly wasteful.
+         ;; Yes.  The above is sligthly wasteful.
 
-           (unification-failure (uf)
-                                (if ,errorp
-                                    (error uf)
-                                    ,error-value))
-           )))))
+         (unification-failure (uf)
+           (if ,errorp
+               (error uf)
+               ,error-value))
+         ))))
 
 
 (defmacro matchf ((template object
@@ -98,8 +98,7 @@
 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-"))
+  (let ((env-var (gensym "UNIFICATION-ENV-"))
         (template (cond ((variablep template)
                          `',template) ; Logical variables are special-cased.
                         ((listp template) ; Same for lists.
@@ -111,28 +110,19 @@
         )
     ;; 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)
-                    )
-	       (declare (ignorable ,@(mapcar #'first
-                                             (generate-var-bindings))))
-               ,@forms)
+    `(block ,match-named
+       (handler-case
+           (let* ((,env-var (unify ,template ,object ,substitution))
+                  )
+             ,(%wrap-var-bindings template env-var forms))
            
-           ;; Yes.  The above is sligthly wasteful.
+         ;; Yes.  The above is sligthly wasteful.
 
-           (unification-failure (uf)
-                                (if ,errorp
-                                    (error uf)
-                                    ,error-value))
-           )))))
+         (unification-failure (uf)
+           (if ,errorp
+               (error uf)
+               ,error-value))
+         ))))
 
 
 
@@ -174,21 +164,12 @@
 "
   (declare (ignore default-substitution)) ; For the time being.
   (labels ((%%match%% (clause-var template object forms substitution)
-             (let ((template-vars (collect-template-vars template))
-                   (template (%template-for-match template))
+             (let ((template (%template-for-match template))
                    )
-               (flet ((generate-var-bindings ()
-                        (loop for v in template-vars
-                              nconc (list `(,v (find-variable-value
-						',v
-						,clause-var))
-                                          `(,(clean-unify-var-name v) ,v))))
-                      )
-                 `((setf ,clause-var
-                         (unify* ,template ,object ,substitution))
-                   (let* (,@(generate-var-bindings))
-                     ,@forms))
-                 )))
+               `((setf ,clause-var
+                       (unify* ,template ,object ,substitution))
+                 ,(%wrap-var-bindings template clause-var forms))
+               ))
 
            (build-match-clause (match-clause match-env-var)
              (destructuring-bind ((template object) &body forms)