Thu Feb 4 07:32:18 UTC 2010 pix@kepibu.org
* Merge all MATCH* macros into a single, unified expansion function
And, because it's now trivial, add MATCH-COND, MATCHF-COND, MATCH-ECASE, and
MATCHF-ECASE.
Still to do: Merge documentation of functions so there's less copy-pasta in the
documentation strings.
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-06-28 10:58:20.000000000 +0000
+++ new-cl-unification-1/match-block.lisp 2013-06-28 10:58:20.000000000 +0000
@@ -10,25 +10,118 @@
(intern (subseq (symbol-name v) 1)
(symbol-package v)))
-(defun %template-for-match (template)
- (if (variablep template)
- `',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)))
+(defun %match-expander (template-munger clause-munger clauses
+ &key default named environment errorp error-form keyform)
+ "A rather hairy internal function which handles expansion for all the MATCH* macros.
+
+template-munger should be either 'match or 'matchf, and will massage the
+template into the proper form for that macro set.
+
+clause-munger should be either 'cond, 'case, or 'nil. This affects the expected
+syntax of items in clauses as follows:
+ 'cond: { ((<template> <object>) &body) }+ default-clause
+ 'case: { (<template> &body) }+ default-clause
+ 'nil: { (<template> <object> &body) }+ default-clause
+ default-clause: [ (t &body) ]
+
+clauses is a list of forms conforming to the syntax just described.
+
+default is a single form to be executed if no other forms match.
+named is the name for a surrounding block.
+
+environment is a base environment object which template matches should extend.
+The new environments created will share frames with this environment, though any
+additional bindings will be in a new, unshared frame. environment defaults to
+'(make-empty-environment).
+
+errorp is a single form which will be evaluated to determine if error-form is
+executed.
+
+error-form is a form which is expected to generate an error (e.g., `(error
+'unification-non-exhaustive)). It defaults to providing the error returned by
+the last form which failed unification.
+
+keyform should be used only for a clause-munger of 'case. It provides the form
+to evaluate to produce the object for unification in -case macros.
+
+*Interaction between default-clause, :errorp + :error-form, and :default
+
+This function produces a giant COND form which ends one or more of these
+assorted \"default\" clauses. They are produced in a very specific order:
+1. errorp + error-form are tried first. Thus, if errorp is 't, neither the
+ default-clause in clauses will be reached, nor the :default clause. This is
+ essentially a hook to produce a pre-user default clause. (e.g., for
+ MATCH's :errorp)
+2. The default-clause in clauses, if it exists, will be tried next. Because
+ clauses is expected to contain user-specified clauses, this is expected to be
+ the user-specified default clause.
+3. Finally, the :default clause, if specified, will be tried. This is
+ essentially a hook to produce a post-user default clause. (e.g., for
+ -ECASE's error form)
+"
+ (flet ((default-clause-p (clause) (member (first clause) '(t otherwise))))
+ (let ((match-environment (gensym "MATCH-ENV-"))
+ (base-environment (gensym "BASE-ENV-"))
+ (match-error (gensym "MATCH-ERR-"))
+ (case-keyform (gensym "KEYFORM-"))
+ (match-clauses (remove-if #'default-clause-p clauses))
+ (default-clauses (remove-if-not #'default-clause-p clauses)))
+ (when (or (and (< 1 (length default-clauses))
+ ;; whether the default clause is the last one
+ (every #'eq clauses (append match-clauses default-clauses)))
+ ;; :keyform only applies for 'case
+ (and keyform (not (eq clause-munger 'case))))
+ (error 'program-error))
+ (labels ((ensure-template (template)
+ (cond (;; Logical variables are special-cased.
+ (variablep template) `',template)
+ ;; Same for lists (under matchf)
+ ((and (eq 'matchf template-munger)
+ (listp template))
+ (make-instance 'list-template
+ :spec (cons 'list template)))
+ (t template)))
+ (bind-variable (v)
+ `((,v (find-variable-value ',v ,match-environment))
+ (,(clean-unify-var-name v) ,v)))
+ (expand-clause (clause)
+ (destructuring-bind (template object &rest body)
+ clause
+ (let* ((template (ensure-template template))
+ (variables (collect-template-vars template)))
+ `((setf (values ,match-environment ,match-error)
+ (unify* ,template ,object (make-expanded-environment ,base-environment)))
+ (let* ,(mapcan #'bind-variable variables)
+ (declare (ignorable ,@variables ,@(mapcar #'clean-unify-var-name variables)))
+ ,@body)))))
+ (munge-clause (clause)
+ (ecase clause-munger
+ (cond (destructuring-bind (head . tail) clause
+ (if (consp head)
+ (list* (car head) (cadr head) tail)
+ clause)))
+ (case (list* (car clause) case-keyform (cdr clause)))
+ ((nil) clause))))
+ `(block ,named
+ (let ((,match-environment nil)
+ (,match-error nil)
+ (,case-keyform ,keyform)
+ (,base-environment ,(if environment
+ `(make-shared-environment ,environment)
+ '(make-empty-environment))))
+ (declare (dynamic-extent ,match-environment ,base-environment)
+ (ignorable ,case-keyform))
+ (cond
+ ,@(mapcar (lambda (c) (expand-clause (munge-clause c))) match-clauses)
+ ,@(when errorp `((,errorp ,(or error-form `(error ,match-error)))))
+ ,@(when default-clauses `((t ,@(cdar default-clauses))))
+ ,@(when default `((t ,default))))))))))
(defmacro match ((template object
&key
- (match-named nil)
- (substitution '(make-empty-environment))
+ (named nil)
+ (match-named nil match-named-p)
+ (substitution nil)
(errorp t)
(error-value nil))
&body forms)
@@ -51,28 +144,21 @@
If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
is set up around the matching code.
"
- (let ((env-var (gensym "UNIFICATION-ENV-"))
- (template (%template-for-match template))
- )
- `(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.
-
- (unification-failure (uf)
- (if ,errorp
- (error uf)
- ,error-value))
- ))))
-
+ (when match-named-p
+ (warn ":match-named is deprecated. Use :named instead."))
+ (%match-expander 'match
+ 'nil
+ `((,template ,object ,@forms))
+ :default error-value
+ :named (or named match-named)
+ :environment substitution
+ :errorp errorp))
(defmacro matchf ((template object
&key
- (match-named nil)
- (substitution '(make-empty-environment))
+ (named nil)
+ (match-named nil match-named-p)
+ (substitution nil)
(errorp t)
(error-value nil))
&body forms)
@@ -98,42 +184,36 @@
If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED
is set up around the matching code.
"
- (let ((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.
- `(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.
-
- (unification-failure (uf)
- (if ,errorp
- (error uf)
- ,error-value))
- ))))
+ (when match-named-p
+ (warn ":match-named is deprecated. Use :named instead."))
+ (%match-expander 'matchf
+ 'nil
+ `((,template ,object ,@forms))
+ :default error-value
+ :named (or named match-named)
+ :environment substitution
+ :errorp errorp))
(define-condition unification-non-exhaustive (unification-failure)
- ())
+ ()
+ (:default-initargs
+ :format-control "Non exhaustive matching."))
+(defmacro match-cond (&body clauses)
+ "A combination of COND and MATCH."
+ (%match-expander 'match 'cond clauses))
+
+(defmacro matchf-cond (&body clauses)
+ "A combination of COND and MATCHF."
+ (%match-expander 'matchf 'cond clauses))
+
(defmacro matching ((&key errorp
- (default-substitution
- (make-empty-environment))
- (matching-named nil))
+ default-substitution
+ (named nil)
+ (matching-named nil matching-named-p))
&body match-clauses)
"MATCHING sets up a COND-like environment for multiple template matching clauses.
@@ -162,54 +242,15 @@
any default clause. Otherwise, the default clause behaves as a
standard COND default clause. The default value of ERRORP is NIL.
"
- (declare (ignore default-substitution)) ; For the time being.
- (labels ((%%match%% (clause-var template object forms substitution)
- (let ((template (%template-for-match template))
- )
- `((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)
- match-clause
- (%%match%% match-env-var
- template
- object
- forms
- '(make-empty-environment))))
- )
- (when (or (and (find t match-clauses :key #'first)
- (find 'otherwise match-clauses :key #'first))
- (> (count t match-clauses :key #'first) 1)
- (> (count 'otherwise match-clauses :key #'first) 1))
- (error 'program-error))
- (let* ((default-clause (or (find t match-clauses
- :key #'first)
- (find 'otherwise match-clauses
- :key #'first)))
- (match-clauses (delete default-clause match-clauses)) ; EQL
- ; test
- ; suffices.
- (env-var (gensym "UNIFICATION-ENV-"))
- )
-
- `(block ,matching-named
- (let (,env-var)
- (declare (dynamic-extent ,env-var))
- (cond ,@(mapcar (lambda (match-clause)
- (build-match-clause match-clause
- env-var))
- match-clauses)
- (,errorp
- (error 'unification-non-exhaustive
- :format-control "Non exhaustive matching."))
- ,@(when default-clause `((t ,@(cdr default-clause))))))))
- ))
-
+ (when matching-named-p
+ (warn ":matching-named is deprecated. Use :named instead."))
+ (%match-expander 'match 'cond match-clauses
+ :errorp errorp
+ :error-form `(error 'unification-non-exhaustive)
+ :named (or named matching-named)
+ :environment default-substitution))
-(defmacro match-case ((object &key errorp default-substitution match-case-named)
+(defmacro match-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))
&body clauses)
"MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.
@@ -238,20 +279,25 @@
any default clause. Otherwise, the default clause behaves as a
standard CASE default clause. The default value of ERRORP is NIL.
"
- (let ((object-var (gensym "OBJECT-VAR-")))
- `(let ((,object-var ,object))
- (matching (:errorp ,errorp :default-substitution ,default-substitution :matching-named ,match-case-named)
- ,@(mapcar
- (lambda (clause)
- `(,(if (member (first clause) '(t otherwise))
- (first clause)
- (list (first clause) object-var))
- ,@(rest clause)))
- clauses)))))
+ (when match-case-named-p
+ (warn ":match-case-named is deprecated. Use :named instead."))
+ (%match-expander 'match 'case clauses
+ :named (or named match-case-named)
+ :environment default-substitution
+ :errorp errorp
+ :error-form `(error 'unification-non-exhaustive)
+ :keyform object))
+
+(defmacro match-ecase ((object &key default-substitution named)
+ &body clauses)
+ (%match-expander 'match 'case clauses
+ :named named
+ :environment default-substitution
+ :default `(error 'unification-non-exhaustive)
+ :keyform object))
-
-(defmacro matchf-case ((object &key errorp default-substitution match-case-named)
- &body clauses)
+(defmacro matchf-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))
+ &body clauses)
"MATCHF-CASE sets up a CASE-like environment for multiple template matching clauses.
The syntax of MATCHF-CASE comprises a number of clauses of the form
@@ -283,33 +329,23 @@
evaluated (i.e., it relies on MATCHF instead of MATCH to construct the
macro expansion.
"
- (declare (ignore default-substitution)) ; For the time being.
- (let* ((object-var (gensym "OBJECT-VAR-"))
- (otherwise-clause-present-p
- (member (caar (last clauses)) '(t otherwise)))
- (non-otherwise-clauses
- (if otherwise-clause-present-p
- (butlast clauses)
- clauses))
- (otherwise-clause
- (if otherwise-clause-present-p
- (first (last clauses))
- (when errorp
- `(t (error 'unification-non-exhaustive
- :format-control "Non exhaustive matching.")))))
- )
- (labels ((generate-matchers (clauses)
- (if (null clauses)
- `(progn ,@(rest otherwise-clause))
- (destructuring-bind (pattern &rest body)
- (car clauses)
- `(handler-case (matchf (,pattern ,object-var)
- ,@body)
- (unification-failure ()
- ,(generate-matchers (cdr clauses))))))))
- `(block ,match-case-named
- (let ((,object-var ,object))
- ,(generate-matchers non-otherwise-clauses))))))
+ (when match-case-named-p
+ (warn ":match-case-named is deprecated. Use :named instead."))
+ (%match-expander 'matchf 'case clauses
+ :named (or named match-case-named)
+ :environment default-substitution
+ :errorp errorp
+ :error-form `(error 'unification-non-exhaustive)
+ :keyform object))
+
+(defmacro matchf-ecase ((object &key default-substitution named)
+ &body clauses)
+ (%match-expander 'matchf 'case clauses
+ :named named
+ :environment default-substitution
+ :default `(error 'unification-non-exhaustive)
+ :keyform object))
+
;;;;---------------------------------------------------------------------------
;;;; Testing.
diff -rN -u old-cl-unification-1/substitutions.lisp new-cl-unification-1/substitutions.lisp
--- old-cl-unification-1/substitutions.lisp 2013-06-28 10:58:20.000000000 +0000
+++ new-cl-unification-1/substitutions.lisp 2013-06-28 10:58:20.000000000 +0000
@@ -118,6 +118,9 @@
(defun make-shared-environment (env)
(make-environment :frames (environment-frames env)))
+(defun make-expanded-environment (base-env)
+ (make-environment :frames (cons (make-frame) (environment-frames base-env))))
+
(defun empty-environment-p (env)
(declare (type environment env))
(let ((env-frames (environment-frames env)))