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)))) + ,@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 ,@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) ,@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.