Wed Apr 15 10:16:24 UTC 2009 mantoniotti
* Added MATCHF (whose name may change) to simplify the
Added MATCHF (whose name may change) to simplify the
'destructuring-bind'-like syntax and behavior of the matching
facilities.
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 20:06:00.000000000 +0000
+++ new-cl-unification-1/match-block.lisp 2013-07-21 20:06:00.000000000 +0000
@@ -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.