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-01 11:57:46.000000000 +0000
+++ new-cl-unification-1/match-block.lisp 2013-07-01 11:57:46.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)