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.
hunk ./match-block.lisp 13
-(defun %template-for-match (template)[_^M_][_$_]
- (if (variablep template)[_^M_][_$_]
- `',template ; Logical variables are special-cased.[_^M_][_$_]
- template))[_^M_][_$_]
+(defun %match-expander (template-munger clause-munger clauses[_^M_][_$_]
+ &key default named environment errorp error-form keyform)[_^M_][_$_]
+ "A rather hairy internal function which handles expansion for all the MATCH* macros.[_^M_][_$_]
hunk ./match-block.lisp 17
-(defun %wrap-var-bindings (template environment-var forms)[_^M_][_$_]
- (let* ((template-vars (collect-template-vars template))[_^M_][_$_]
- (bindings (loop for v in template-vars[_^M_][_$_]
- nconc (list `(,v (find-variable-value ',v[_^M_][_$_]
- ,environment-var))[_^M_][_$_]
- `(,(clean-unify-var-name v) ,v)))))[_^M_][_$_]
- `(let* ,bindings[_^M_][_$_]
- (declare (ignorable ,@(mapcar #'first bindings)))[_^M_][_$_]
- ,@forms)))[_^M_][_$_]
+template-munger should be either 'match or 'matchf, and will massage the[_^M_][_$_]
+template into the proper form for that macro set.[_^M_][_$_]
+[_^M_][_$_]
+clause-munger should be either 'cond, 'case, or 'nil. This affects the expected[_^M_][_$_]
+syntax of items in clauses as follows:[_^M_][_$_]
+ 'cond: { ((<template> <object>) &body) }+ default-clause[_^M_][_$_]
+ 'case: { (<template> &body) }+ default-clause[_^M_][_$_]
+ 'nil: { (<template> <object> &body) }+ default-clause[_^M_][_$_]
+ default-clause: [ (t &body) ][_^M_][_$_]
+[_^M_][_$_]
+clauses is a list of forms conforming to the syntax just described.[_^M_][_$_]
+[_^M_][_$_]
+default is a single form to be executed if no other forms match.[_^M_][_$_]
+named is the name for a surrounding block.[_^M_][_$_]
+[_^M_][_$_]
+environment is a base environment object which template matches should extend.[_^M_][_$_]
+The new environments created will share frames with this environment, though any[_^M_][_$_]
+additional bindings will be in a new, unshared frame. environment defaults to[_^M_][_$_]
+'(make-empty-environment).[_^M_][_$_]
+[_^M_][_$_]
+errorp is a single form which will be evaluated to determine if error-form is[_^M_][_$_]
+executed.[_^M_][_$_]
+[_^M_][_$_]
+error-form is a form which is expected to generate an error (e.g., `(error[_^M_][_$_]
+'unification-non-exhaustive)). It defaults to providing the error returned by[_^M_][_$_]
+the last form which failed unification.[_^M_][_$_]
+[_^M_][_$_]
+keyform should be used only for a clause-munger of 'case. It provides the form[_^M_][_$_]
+to evaluate to produce the object for unification in -case macros.[_^M_][_$_]
+[_^M_][_$_]
+*Interaction between default-clause, :errorp + :error-form, and :default[_^M_][_$_]
+[_^M_][_$_]
+This function produces a giant COND form which ends one or more of these[_^M_][_$_]
+assorted \"default\" clauses. They are produced in a very specific order:[_^M_][_$_]
+1. errorp + error-form are tried first. Thus, if errorp is 't, neither the[_^M_][_$_]
+ default-clause in clauses will be reached, nor the :default clause. This is[_^M_][_$_]
+ essentially a hook to produce a pre-user default clause. (e.g., for[_^M_][_$_]
+ MATCH's :errorp)[_^M_][_$_]
+2. The default-clause in clauses, if it exists, will be tried next. Because[_^M_][_$_]
+ clauses is expected to contain user-specified clauses, this is expected to be[_^M_][_$_]
+ the user-specified default clause.[_^M_][_$_]
+3. Finally, the :default clause, if specified, will be tried. This is[_^M_][_$_]
+ essentially a hook to produce a post-user default clause. (e.g., for[_^M_][_$_]
+ -ECASE's error form)[_^M_][_$_]
+"[_^M_][_$_]
+ (flet ((default-clause-p (clause) (member (first clause) '(t otherwise))))[_^M_][_$_]
+ (let ((match-environment (gensym "MATCH-ENV-"))[_^M_][_$_]
+ (base-environment (gensym "BASE-ENV-"))[_^M_][_$_]
+ (match-error (gensym "MATCH-ERR-"))[_^M_][_$_]
+ (case-keyform (gensym "KEYFORM-"))[_^M_][_$_]
+ (match-clauses (remove-if #'default-clause-p clauses))[_^M_][_$_]
+ (default-clauses (remove-if-not #'default-clause-p clauses)))[_^M_][_$_]
+ (when (or (and (< 1 (length default-clauses))[_^M_][_$_]
+ ;; whether the default clause is the last one[_^M_][_$_]
+ (every #'eq clauses (append match-clauses default-clauses)))[_^M_][_$_]
+ ;; :keyform only applies for 'case[_^M_][_$_]
+ (and keyform (not (eq clause-munger 'case))))[_^M_][_$_]
+ (error 'program-error))[_^M_][_$_]
+ (labels ((ensure-template (template)[_^M_][_$_]
+ (cond (;; Logical variables are special-cased.[_^M_][_$_]
+ (variablep template) `',template)[_^M_][_$_]
+ ;; Same for lists (under matchf)[_^M_][_$_]
+ ((and (eq 'matchf template-munger)[_^M_][_$_]
+ (listp template))[_^M_][_$_]
+ (make-instance 'list-template[_^M_][_$_]
+ :spec (cons 'list template)))[_^M_][_$_]
+ (t template)))[_^M_][_$_]
+ (bind-variable (v)[_^M_][_$_]
+ `((,v (find-variable-value ',v ,match-environment))[_^M_][_$_]
+ (,(clean-unify-var-name v) ,v)))[_^M_][_$_]
+ (expand-clause (clause)[_^M_][_$_]
+ (destructuring-bind (template object &rest body)[_^M_][_$_]
+ clause[_^M_][_$_]
+ (let* ((template (ensure-template template))[_^M_][_$_]
+ (variables (collect-template-vars template)))[_^M_][_$_]
+ `((setf (values ,match-environment ,match-error)[_^M_][_$_]
+ (unify* ,template ,object (make-expanded-environment ,base-environment)))[_^M_][_$_]
+ (let* ,(mapcan #'bind-variable variables)[_^M_][_$_]
+ (declare (ignorable ,@variables ,@(mapcar #'clean-unify-var-name variables)))[_^M_][_$_]
+ ,@body)))))[_^M_][_$_]
+ (munge-clause (clause)[_^M_][_$_]
+ (ecase clause-munger[_^M_][_$_]
+ (cond (destructuring-bind (head . tail) clause[_^M_][_$_]
+ (if (consp head)[_^M_][_$_]
+ (list* (car head) (cadr head) tail)[_^M_][_$_]
+ clause)))[_^M_][_$_]
+ (case (list* (car clause) case-keyform (cdr clause)))[_^M_][_$_]
+ ((nil) clause))))[_^M_][_$_]
+ `(block ,named[_^M_][_$_]
+ (let ((,match-environment nil)[_^M_][_$_]
+ (,match-error nil)[_^M_][_$_]
+ (,case-keyform ,keyform)[_^M_][_$_]
+ (,base-environment ,(if environment[_^M_][_$_]
+ `(make-shared-environment ,environment)[_^M_][_$_]
+ '(make-empty-environment))))[_^M_][_$_]
+ (declare (dynamic-extent ,match-environment ,base-environment)[_^M_][_$_]
+ (ignorable ,case-keyform))[_^M_][_$_]
+ (cond[_^M_][_$_]
+ ,@(mapcar (lambda (c) (expand-clause (munge-clause c))) match-clauses)[_^M_][_$_]
+ ,@(when errorp `((,errorp ,(or error-form `(error ,match-error)))))[_^M_][_$_]
+ ,@(when default-clauses `((t ,@(cdar default-clauses))))[_^M_][_$_]
+ ,@(when default `((t ,default))))))))))[_^M_][_$_]
hunk ./match-block.lisp 122
- (match-named nil)[_^M_][_$_]
- (substitution '(make-empty-environment))[_^M_][_$_]
+ (named nil)[_^M_][_$_]
+ (match-named nil match-named-p)[_^M_][_$_]
+ (substitution nil)[_^M_][_$_]
hunk ./match-block.lisp 147
- (let ((env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]
- (template (%template-for-match template))[_^M_][_$_]
- )[_^M_][_$_]
- `(block ,match-named[_^M_][_$_]
- (handler-case[_^M_][_$_]
- (let* ((,env-var (unify ,template ,object ,substitution))[_^M_][_$_]
- )[_^M_][_$_]
- ,(%wrap-var-bindings template env-var forms))[_^M_][_$_]
- [_^M_][_$_]
- ;; Yes. The above is sligthly wasteful.[_^M_][_$_]
-[_^M_][_$_]
- (unification-failure (uf)[_^M_][_$_]
- (if ,errorp[_^M_][_$_]
- (error uf)[_^M_][_$_]
- ,error-value))[_^M_][_$_]
- ))))[_^M_][_$_]
-[_^M_][_$_]
+ (when match-named-p[_^M_][_$_]
+ (warn ":match-named is deprecated. Use :named instead."))[_^M_][_$_]
+ (%match-expander 'match[_^M_][_$_]
+ 'nil[_^M_][_$_]
+ `((,template ,object ,@forms))[_^M_][_$_]
+ :default error-value[_^M_][_$_]
+ :named (or named match-named)[_^M_][_$_]
+ :environment substitution[_^M_][_$_]
+ :errorp errorp))[_^M_][_$_]
hunk ./match-block.lisp 159
- (match-named nil)[_^M_][_$_]
- (substitution '(make-empty-environment))[_^M_][_$_]
+ (named nil)[_^M_][_$_]
+ (match-named nil match-named-p)[_^M_][_$_]
+ (substitution nil)[_^M_][_$_]
hunk ./match-block.lisp 187
- (let ((env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]
- (template (cond ((variablep template)[_^M_][_$_]
- `',template) ; Logical variables are special-cased.[_^M_][_$_]
- ((listp template) ; Same for lists.[_^M_][_$_]
- (make-instance 'list-template[_^M_][_$_]
- :spec (cons 'list template)))[_^M_][_$_]
- ;`',template)[_^M_][_$_]
- (t[_^M_][_$_]
- template)))[_^M_][_$_]
- )[_^M_][_$_]
- ;; Logical variables and lists are special cased for convenience.[_^M_][_$_]
- ;; Lists are especially inteded as abbreviation for destructuring.[_^M_][_$_]
- `(block ,match-named[_^M_][_$_]
- (handler-case[_^M_][_$_]
- (let* ((,env-var (unify ,template ,object ,substitution))[_^M_][_$_]
- )[_^M_][_$_]
- ,(%wrap-var-bindings template env-var forms))[_^M_][_$_]
- [_^M_][_$_]
- ;; Yes. The above is sligthly wasteful.[_^M_][_$_]
-[_^M_][_$_]
- (unification-failure (uf)[_^M_][_$_]
- (if ,errorp[_^M_][_$_]
- (error uf)[_^M_][_$_]
- ,error-value))[_^M_][_$_]
- ))))[_^M_][_$_]
+ (when match-named-p[_^M_][_$_]
+ (warn ":match-named is deprecated. Use :named instead."))[_^M_][_$_]
+ (%match-expander 'matchf[_^M_][_$_]
+ 'nil[_^M_][_$_]
+ `((,template ,object ,@forms))[_^M_][_$_]
+ :default error-value[_^M_][_$_]
+ :named (or named match-named)[_^M_][_$_]
+ :environment substitution[_^M_][_$_]
+ :errorp errorp))[_^M_][_$_]
hunk ./match-block.lisp 200
- ())[_^M_][_$_]
+ ()[_^M_][_$_]
+ (:default-initargs[_^M_][_$_]
+ :format-control "Non exhaustive matching."))[_^M_][_$_]
+[_^M_][_$_]
hunk ./match-block.lisp 205
+(defmacro match-cond (&body clauses)[_^M_][_$_]
+ "A combination of COND and MATCH."[_^M_][_$_]
+ (%match-expander 'match 'cond clauses))[_^M_][_$_]
+[_^M_][_$_]
+(defmacro matchf-cond (&body clauses)[_^M_][_$_]
+ "A combination of COND and MATCHF."[_^M_][_$_]
+ (%match-expander 'matchf 'cond clauses))[_^M_][_$_]
hunk ./match-block.lisp 214
- (default-substitution[_^M_][_$_]
- (make-empty-environment))[_^M_][_$_]
- (matching-named nil))[_^M_][_$_]
+ default-substitution[_^M_][_$_]
+ (named nil)[_^M_][_$_]
+ (matching-named nil matching-named-p))[_^M_][_$_]
hunk ./match-block.lisp 245
- (declare (ignore default-substitution)) ; For the time being.[_^M_][_$_]
- (labels ((%%match%% (clause-var template object forms substitution)[_^M_][_$_]
- (let ((template (%template-for-match template))[_^M_][_$_]
- )[_^M_][_$_]
- `((setf ,clause-var[_^M_][_$_]
- (unify* ,template ,object ,substitution))[_^M_][_$_]
- ,(%wrap-var-bindings template clause-var forms))[_^M_][_$_]
- ))[_^M_][_$_]
-[_^M_][_$_]
- (build-match-clause (match-clause match-env-var)[_^M_][_$_]
- (destructuring-bind ((template object) &body forms)[_^M_][_$_]
- match-clause[_^M_][_$_]
- (%%match%% match-env-var[_^M_][_$_]
- template[_^M_][_$_]
- object[_^M_][_$_]
- forms[_^M_][_$_]
- '(make-empty-environment))))[_^M_][_$_]
- )[_^M_][_$_]
- (when (or (and (find t match-clauses :key #'first)[_^M_][_$_]
- (find 'otherwise match-clauses :key #'first))[_^M_][_$_]
- (> (count t match-clauses :key #'first) 1)[_^M_][_$_]
- (> (count 'otherwise match-clauses :key #'first) 1))[_^M_][_$_]
- (error 'program-error))[_^M_][_$_]
- (let* ((default-clause (or (find t match-clauses[_^M_][_$_]
- :key #'first)[_^M_][_$_]
- (find 'otherwise match-clauses[_^M_][_$_]
- :key #'first)))[_^M_][_$_]
- (match-clauses (delete default-clause match-clauses)) ; EQL[_^M_][_$_]
- ; test[_^M_][_$_]
- ; suffices.[_^M_][_$_]
- (env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]
- )[_^M_][_$_]
+ (when matching-named-p[_^M_][_$_]
+ (warn ":matching-named is deprecated. Use :named instead."))[_^M_][_$_]
+ (%match-expander 'match 'cond match-clauses[_^M_][_$_]
+ :errorp errorp[_^M_][_$_]
+ :error-form `(error 'unification-non-exhaustive)[_^M_][_$_]
+ :named (or named matching-named)[_^M_][_$_]
+ :environment default-substitution))[_^M_][_$_]
hunk ./match-block.lisp 253
- `(block ,matching-named[_^M_][_$_]
- (let (,env-var)[_^M_][_$_]
- (declare (dynamic-extent ,env-var))[_^M_][_$_]
- (cond ,@(mapcar (lambda (match-clause)[_^M_][_$_]
- (build-match-clause match-clause[_^M_][_$_]
- env-var))[_^M_][_$_]
- match-clauses)[_^M_][_$_]
- (,errorp[_^M_][_$_]
- (error 'unification-non-exhaustive[_^M_][_$_]
- :format-control "Non exhaustive matching."))[_^M_][_$_]
- ,@(when default-clause `((t ,@(cdr default-clause))))))))[_^M_][_$_]
- ))[_^M_][_$_]
-[_^M_][_$_]
-[_^M_][_$_]
-(defmacro match-case ((object &key errorp default-substitution match-case-named)[_^M_][_$_]
+(defmacro match-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))[_^M_][_$_]
hunk ./match-block.lisp 282
- (let ((object-var (gensym "OBJECT-VAR-")))[_^M_][_$_]
- `(let ((,object-var ,object))[_^M_][_$_]
- (matching (:errorp ,errorp :default-substitution ,default-substitution :matching-named ,match-case-named)[_^M_][_$_]
- ,@(mapcar[_^M_][_$_]
- (lambda (clause)[_^M_][_$_]
- `(,(if (member (first clause) '(t otherwise))[_^M_][_$_]
- (first clause)[_^M_][_$_]
- (list (first clause) object-var))[_^M_][_$_]
- ,@(rest clause)))[_^M_][_$_]
- clauses)))))[_^M_][_$_]
+ (when match-case-named-p[_^M_][_$_]
+ (warn ":match-case-named is deprecated. Use :named instead."))[_^M_][_$_]
+ (%match-expander 'match 'case clauses[_^M_][_$_]
+ :named (or named match-case-named)[_^M_][_$_]
+ :environment default-substitution[_^M_][_$_]
+ :errorp errorp[_^M_][_$_]
+ :error-form `(error 'unification-non-exhaustive)[_^M_][_$_]
+ :keyform object))[_^M_][_$_]
hunk ./match-block.lisp 291
+(defmacro match-ecase ((object &key default-substitution named)[_^M_][_$_]
+ &body clauses)[_^M_][_$_]
+ (%match-expander 'match 'case clauses[_^M_][_$_]
+ :named named[_^M_][_$_]
+ :environment default-substitution[_^M_][_$_]
+ :default `(error 'unification-non-exhaustive)[_^M_][_$_]
+ :keyform object))[_^M_][_$_]
hunk ./match-block.lisp 299
-(defmacro matchf-case ((object &key errorp default-substitution match-case-named)[_^M_][_$_]
- &body clauses)[_^M_][_$_]
+(defmacro matchf-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))[_^M_][_$_]
+ &body clauses)[_^M_][_$_]
hunk ./match-block.lisp 332
- (declare (ignore default-substitution)) ; For the time being.[_^M_][_$_]
- (let* ((object-var (gensym "OBJECT-VAR-"))[_^M_][_$_]
- (otherwise-clause-present-p[_^M_][_$_]
- (member (caar (last clauses)) '(t otherwise)))[_^M_][_$_]
- (non-otherwise-clauses[_^M_][_$_]
- (if otherwise-clause-present-p[_^M_][_$_]
- (butlast clauses)[_^M_][_$_]
- clauses))[_^M_][_$_]
- (otherwise-clause[_^M_][_$_]
- (if otherwise-clause-present-p[_^M_][_$_]
- (first (last clauses))[_^M_][_$_]
- (when errorp[_^M_][_$_]
- `(t (error 'unification-non-exhaustive[_^M_][_$_]
- :format-control "Non exhaustive matching.")))))[_^M_][_$_]
- )[_^M_][_$_]
- (labels ((generate-matchers (clauses)[_^M_][_$_]
- (if (null clauses)[_^M_][_$_]
- `(progn ,@(rest otherwise-clause))[_^M_][_$_]
- (destructuring-bind (pattern &rest body)[_^M_][_$_]
- (car clauses)[_^M_][_$_]
- `(handler-case (matchf (,pattern ,object-var)[_^M_][_$_]
- ,@body)[_^M_][_$_]
- (unification-failure ()[_^M_][_$_]
- ,(generate-matchers (cdr clauses))))))))[_^M_][_$_]
- `(block ,match-case-named[_^M_][_$_]
- (let ((,object-var ,object))[_^M_][_$_]
- ,(generate-matchers non-otherwise-clauses))))))[_^M_][_$_]
+ (when match-case-named-p[_^M_][_$_]
+ (warn ":match-case-named is deprecated. Use :named instead."))[_^M_][_$_]
+ (%match-expander 'matchf 'case clauses[_^M_][_$_]
+ :named (or named match-case-named)[_^M_][_$_]
+ :environment default-substitution[_^M_][_$_]
+ :errorp errorp[_^M_][_$_]
+ :error-form `(error 'unification-non-exhaustive)[_^M_][_$_]
+ :keyform object))[_^M_][_$_]
+[_^M_][_$_]
+(defmacro matchf-ecase ((object &key default-substitution named)[_^M_][_$_]
+ &body clauses)[_^M_][_$_]
+ (%match-expander 'matchf 'case clauses[_^M_][_$_]
+ :named named[_^M_][_$_]
+ :environment default-substitution[_^M_][_$_]
+ :default `(error 'unification-non-exhaustive)[_^M_][_$_]
+ :keyform object))[_^M_][_$_]
+[_^M_][_$_]
hunk ./substitutions.lisp 121
+(defun make-expanded-environment (base-env)
+ (make-environment :frames (cons (make-frame) (environment-frames base-env))))
+