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/match-block.lisp new-cl-unification/match-block.lisp
--- old-cl-unification/match-block.lisp	2013-12-22 19:10:57.000000000 +0000
+++ new-cl-unification/match-block.lisp	2013-12-22 19:10:57.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/substitutions.lisp new-cl-unification/substitutions.lisp
--- old-cl-unification/substitutions.lisp	2013-12-22 19:10:57.000000000 +0000
+++ new-cl-unification/substitutions.lisp	2013-12-22 19:10:57.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)))