Tue Mar 13 15:29:16 UTC 2012 mantoniotti@common-lisp.net

* Added TIMESTAMP.

+20120116

Tue Mar 13 15:28:28 UTC 2012 mantoniotti@common-lisp.net

* Copyright updated.

- © 2004-2011, Marco Antoniotti, all rights reserved.

+ © 2004-2012, Marco Antoniotti, all rights reserved.

Tue Mar 13 15:28:15 UTC 2012 mantoniotti@common-lisp.net

* Copyright updated.

-Copyright (c) 2004-2011 Marco Antoniotti[_^M_][_$_]

+Copyright (c) 2004-2012 Marco Antoniotti[_^M_][_$_]

Thu Jun 16 00:10:47 UTC 2011 mantoniotti@common-lisp.net

* Added "CL-UNIFICATION" as package nickname to match the .asd and .system specs.

- (:nicknames "CL.EXT.DACF.UNIFICATION" "UNIFY" "unify")

+ (:nicknames "CL.EXT.DACF.UNIFICATION" "UNIFY" "unify" "CL-UNIFICATION")

Sat Apr 2 04:39:32 UTC 2011 rbrown@common-lisp.net

* Use *unify-string-case-sensitive-p* consistently.

Change the documentation.

- <p>The value of the variable *UNIFY-STRING-CASE-INSENSITIVE-P*.</p>

+ <p>The value of the variable *UNIFY-STRING-CASE-SENSITIVE-P*.</p>

- <li><a href="usci-variable.html"><i>Variable</i> <b>*UNIFY-STRING-CASE-INSENSITIVE*</b></a>

+ <li><a href="usci-variable.html"><i>Variable</i> <b>*UNIFY-STRING-CASE-SENSITIVE*</b></a>

- condition. If the variable *UNIFY-STRING-CASE-INSENSITIVE-P* is NIL

+ condition. If the variable *UNIFY-STRING-CASE-SENSITIVE-P* is T

- *UNIFY-STRING-CASE-INSENSITIVE-P*, OCCURS-IN-P,

+ *UNIFY-STRING-CASE-SENSITIVE-P*, OCCURS-IN-P,

- <title>CL Unification: Variable *UNIFY-STRING-CASE-INSENSITIVE-P*</title>

+ <title>CL Unification: Variable *UNIFY-STRING-CASE-SENSITIVE-P*</title>

- <strong><i>CL Unification: Variable *UNIFY-STRING-CASE-INSENSITIVE-P*</title></i></strong>

+ <strong><i>CL Unification: Variable *UNIFY-STRING-CASE-SENSITIVE-P*</title></i></strong>

- <h1><i>Variable</i> <strong>*UNIFY-STRING-CASE-INSENSITIVE-P*</strong></h1>

+ <h1><i>Variable</i> <strong>*UNIFY-STRING-CASE-SENSITIVE-P*</strong></h1>

- <p>The value of *UNIFY-STRING-CASE-INSENSITIVE-P* controls the

+ <p>The value of *UNIFY-STRING-CASE-SENSITIVE-P* controls the

- If NIL (the default), the method will use STRING= to test for

+ If T (the default), the method will use STRING= to test for

- (test t (let ((*unify-string-case-insensitive-p* t))

+ (test t (let ((*unify-string-case-sensitive-p* nil))

- "*UNIFY-STRING-CASE-INSENSITIVE-P*"

+ "*UNIFY-STRING-CASE-SENSITIVE-P*"

-*UNIFY-STRING-CASE-INSENSITIVE-P*, which defaults to NIL.

+*UNIFY-STRING-CASE-SENSITIVE-P*, which defaults to T.

-*UNIFY-STRING-CASE-INSENSITIVE-P*, which defaults to NIL.

+*UNIFY-STRING-CASE-SENSITIVE-P*, which defaults to T.

Sat Apr 2 04:19:09 UTC 2011 rbrown@common-lisp.net

* match-block.lisp: Use &body in match-case and matchf-case so

+2011-03-28 Robert Brown <robert.brown at gmail.com>

+

+ * match-block.lisp: Use &body in match-case and matchf-case so

+ code that uses them is correctly indented by editors.

+

Sat Apr 2 04:16:51 UTC 2011 mantoniotti@common-lisp.net

* Copyright updated.

- <h1>News</h1>

+<!-- <h1>News</h1>

-

+-->

+ [_$_]

- &copy; 2003-2004, Marco Antoniotti, all rights reserved.

+ &copy; 2003-2011, Marco Antoniotti, all rights reserved.

-;;; Copyright (c) 2004 Marco Antoniotti, All rigths reserved.

+;;; Copyright (c) 2004-2011 Marco Antoniotti, All rigths reserved.

- <h1>News</h1>

+<!-- <h1>News</h1>

-

+-->

- &copy; 2003-2004, Marco Antoniotti, all rights reserved.

+ &copy; 2003-2011, Marco Antoniotti, all rights reserved.

- <h1>News</h1>

+<!-- <h1>News</h1>

-

+-->

- &copy; 2003-2004, Marco Antoniotti, all rights reserved.

+ &copy; 2003-2011, Marco Antoniotti, all rights reserved.

- <h1>News</h1>

+ <!-- <h1>News</h1>

-

+-->

+ [_$_]

- &copy; 2003-2004, Marco Antoniotti, all rights reserved.

+ &copy; 2003-2011, Marco Antoniotti, all rights reserved.

-;;; Copyright (c) 2004-2005 Marco Antoniotti, All rigths reserved.

+;;; Copyright (c) 2004-2011 Marco Antoniotti, All rigths reserved.

- <h1>News</h1>

+<!-- <h1>News</h1>

-

+-->

- &copy; 2003-2004, Marco Antoniotti, all rights reserved.

+ &copy; 2003-2011, Marco Antoniotti, all rights reserved.

- <h1>News</h1>

+<!-- <h1>News</h1>

-

+-->

- &copy; 2003-2004, Marco Antoniotti, all rights reserved.

+ &copy; 2003-2011, Marco Antoniotti, all rights reserved.

- <h1>News</h1>

+<!-- <h1>News</h1>

-

+-->

- &copy; 2003-2004, Marco Antoniotti, all rights reserved.

+ &copy; 2003-2011, Marco Antoniotti, all rights reserved.

- <h1>News</h1>

+<!-- <h1>News</h1>

-

+-->

- &copy; 2003-2004, Marco Antoniotti, all rights reserved.

+ &copy; 2003-2011, Marco Antoniotti, all rights reserved.

Sat Apr 2 04:11:54 UTC 2011 mantoniotti@common-lisp.net

* Updated copyright info and a News.

-;;; Copyright (c) 2004 Marco Antoniotti, All rigths reserved.

+;;; Copyright (c) 2004-2011 Marco Antoniotti, All rigths reserved.

+ <li><strong>2011-02-20</strong><br>

+ CL-UNIFICATION is now in <a href="www.quicklisp.org">Quicklisp</a>.

- &copy; 2004-2007, Marco Antoniotti, all rights reserved.

+ &copy; 2004-2011, Marco Antoniotti, all rights reserved.

Sat Apr 2 04:09:17 UTC 2011 mantoniotti@common-lisp.net

* ChangeLog updated.

+2011-02-27 author <author at paniscia.local>

+

+ * .cvsignore: Updated.

+

+ * docs/html/images/Thumbs.db, docs/html/images/Thumbs.db:encryptable:

+ Removed Files:

+ Thumbs.db Thumbs.db:encryptable

+

+2011-02-26 author <author at paniscia.local>

+

+ * .cvsignore: Updated.

+

+ * variables.lisp, unifier.lisp:

+ Minor changes (added COPYING information and other minutiae).

+

+ * unification-package.lisp: Exported a few more symbols.

+

+ * templates-hierarchy.lisp:

+ Minor changes (added COPYING information and other minutiae).

+

+ * substitutions.lisp:

+ Changed some environment functions and improved the DUMP-* ones.

+

+ * match-block.lisp, lambda-list-parsing.lisp, cl-unification.system, cl-unification.asd, cl-unification-lib.asd, apply-substitution.lisp:

+ Minor changes (added COPYING information and other minutiae).

+

+ * ACKNOWLEDGEMENTS: Acknowledgements updated.

+

+2011-02-24 author <author at paniscia.local>

+

+ * ChangeLog, apply-substitution.lisp, cl-unification.system, lambda-list-parsing.lisp, lib-dependent/cl-ppcre-template.lisp, match-block.lisp, templates-hierarchy.lisp, unifier.lisp:

+ Delete trailing whitespace. In lambda-list-parsing.lisp this fixes a bug

+ with ~@<newline> format directives.

+

+ * ChangeLog, test/unification-tests.lisp, unifier.lisp:

+ unifier.lisp: Allow vectors to unify with sequence templates.

+ test/unification-tests.lisp: new test to verify the change

+

Sat Apr 2 04:08:13 UTC 2011 mantoniotti@common-lisp.net

* Remove Thumbs.db and friends

Sat Apr 2 04:05:30 UTC 2011 mantoniotti@common-lisp.net

* Exported a few more symbols.

- (:export

- "ENABLE-TEMPLATE-READER"

- "MAKE-TEMPLATE"

- "TEMPLATEP"

- "TEMPLATE-SPEC")

-

- "FIND-VARIABLE-VALUE"

- "V?"

- "MAKE-EMPTY-ENVIRONMENT"

- "ENVIRONMENT-P")

+ "ENVIRONMENT-P"

+ "MAKE-EMPTY-ENVIRONMENT"

+ "EMPTY-ENVIRONMENT-P"

+ "MAKE-SHARED-ENVIRONMENT"

+ "COPY-ENVIRONMENT"

+ [_$_]

+ "PUSH-FRAME"

+ "POP-FRAME"

+

+ "BINDING-VARIABLE"

+ "BINDING-VALUE"

+

+ "EXTEND-ENVIRONMENT"

+ "FILL-ENVIRONMENT"

+ "FILL-ENVIRONMENT*"

+

+ "FIND-VARIABLE-VALUE"

+ "V?"

+

+ "NEW-VAR"

+ "VARIABLEP"

+ "VARIABLE-ANY-P"

+ )

+ (:export

+ "ENABLE-TEMPLATE-READER"

+ "MAKE-TEMPLATE"

+ "TEMPLATEP"

+ "TEMPLATE-SPEC"

+

+ "COLLECT-TEMPLATE-VARS"

+ )

+

Sat Apr 2 04:05:18 UTC 2011 mantoniotti@common-lisp.net

* Minor changes (added COPYING information and other minutiae).

-;;; -*- Mode: Lisp -*-

+;;;; -*- Mode: Lisp -*-

-;;; substitutions.lisp

-;;; General CL structures unifier.

-;;; Substitution definitions.

+;;;; apply-substitutions.lisp --

+;;;; General CL structures unifier.

+;;;; Substitution definitions.

+;;;;

+;;;; See the file COPYING for copyright and licensing information.

-;;; end of file -- apply-substitutions.lisp --

+;;;; end of file -- apply-substitutions.lisp --

+;;;;

+;;;; See file COPYING for copyright and licensing information.

+;;;; See file COPYING for copyright licensing information.

+

+;;;; See file COPYING for copyright licensing information.

+

+;;;; See file COPYING for copyright licensing information.[_^M_][_$_]

+[_^M_][_$_]

+;;;; See file COPYING for copyright licensing information.[_^M_][_$_]

+[_^M_][_$_]

+;;;; See file COPYING for copyright licensing information.

+

+;;;; See file COPYING for copyright licensing information.

+

-;;;; Copyright (c) 2004-2009 Marco Antoniotti

-;;;; See file COPYING for licensing information.

+;;;; Copyright (c) 2004-2011 Marco Antoniotti

+;;;; See file COPYING for copyright licensing information.

+;;;; See file COPYING for copyright licensing information.

+

-;;; -*- Mode: Lisp -*-

+;;;; -*- Mode: Lisp -*-

+

+;;;; variables.lisp --

+

+;;;; See file COPYING for copyright licensing information.

-(defun make-var-name (&optional (s (gensym "UNIFVAR-")) (package *package*))

- (intern (concatenate 'string "?" (symbol-name s)) package))

+(defun make-var-name (&optional (s (gensym "UV_")) (package *package*))

+ (declare (type (or string symbol character) s))

+ (intern (concatenate 'string "?" (string s)) package))

+

+

+(eval-when (:load-toplevel :execute)

+ (setf (fdefinition 'new-var) #'make-var-name))

Sat Apr 2 04:01:24 UTC 2011 mantoniotti@common-lisp.net

* Changed some environment functions and improved the DUMP-* ones.

+ (declare (type environment env))

-(defun make-shared-environment (env)

- (make-environment :frames (environment-frames env)))

+(defun make-shared-environment (env &optional (pushp nil))

+ (declare (type environment env))

+ (make-environment :frames (if pushp

+ (cons (make-frame) (environment-frames env))

+ (environment-frames env))))

+

+(defun push-frame (env)

+ (declare (type environment env))

+ (push (make-frame) (environment-frames env)))

+

+(defun pop-frame (env)

+ (declare (type environment env))

+ (pop (environment-frames env)))

+

- (terpri out)

- do (format out "~A~VT= ~A~%" var 8 value))

+ do (format out "~&~A~VT= ~A~%" var 8 value))

- (map nil #'(lambda (f) (dump-frame f out)) (environment-frames env)))

+ (if (empty-environment-p env)

+ (format out ">>> Empty unify environment ~S.~%" env)

+ (loop initially (format out ">>> Dumping unify environment ~S.~%" env)

+ for fr in (environment-frames env)

+ for fr-n downfrom (list-length (environment-frames env))

+ do (format out ">>> Frame ~D:~%" fr-n)

+ do (dump-frame fr out)

+ do (terpri out)

+ )))

Sat Apr 2 03:51:38 UTC 2011 mantoniotti@common-lisp.net

* Acknowledgements updated.

+Brown, Robert

Sat Apr 2 03:50:19 UTC 2011 rbrown@common-lisp.net

* Delete trailing whitespace. In lambda-list-parsing.lisp this fixes a bug

with ~@<newline> format directives.

+ * lambda-list-parsing.lisp: Delete trailing whitespace that turned

+ ~@<newline> into a bogus format directive by converting it into

+ ~@<space><newline>

+

+ * unifier.lisp, apply-substitution.lisp, cl-unification.system

+ * match-block.lisp, templates-hierarchy.lisp, unifier.lisp

+ * lib-dependent/cl-ppcre-template.lisp: delete trailing whitespace

+

+2011-02-24 Robert Brown <robert.brown at gmail.com>

+

- [_$_]

- [_$_]

+

+

- [_$_]

+

-;;; definition of LAMBDA-LIST-KEYWORDS [_^M_][_$_]

+;;; definition of LAMBDA-LIST-KEYWORDS.[_^M_][_$_]

- (warn "Keyword ~A is implementation dependent.~@ [_^M_][_$_]

+ (warn "Keyword ~A is implementation dependent.~@[_^M_][_$_]

- (warn "Keyword ~A is implementation dependent.~@ [_^M_][_$_]

+ (warn "Keyword ~A is implementation dependent.~@[_^M_][_$_]

- (warn "Keyword ~A is implementation dependent.~@ [_^M_][_$_]

+ (warn "Keyword ~A is implementation dependent.~@[_^M_][_$_]

- (warn "Keyword ~A is implementation dependent.~@ [_^M_][_$_]

+ (warn "Keyword ~A is implementation dependent.~@[_^M_][_$_]

- (warn "Keyword ~A is implementation dependent.~@ [_^M_][_$_]

+ (warn "Keyword ~A is implementation dependent.~@[_^M_][_$_]

- (warn "Keyword ~A is implementation dependent.~@ [_^M_][_$_]

+ (warn "Keyword ~A is implementation dependent.~@[_^M_][_$_]

- [_^M_][_$_]

+[_^M_][_$_]

- [_$_]

+

- [_$_]

+

- [_$_]

+

- [_$_]

+

Sat Apr 2 02:51:32 UTC 2011 rbrown@common-lisp.net

* unifier.lisp: Allow vectors to unify with sequence templates.

test/unification-tests.lisp: new test to verify the change

+2011-02-24 Robert Brown <robert.brown at gmail.com>

+

+ * unifier.lisp: Allow vectors to unify with sequence templates.

+ * test/unification-tests.lisp: new test to verify the change

+

+ (test '(42 T) (v? '?x (unify #(0 1 42 3 4 5) #T(sequence 0 1 ?x 3 4 5)))

+ :multiple-values t)

-(defmethod unify ((a vector) (b vector-template)

+(defmethod unify ((a vector) (b sequence-template)

Sat Apr 2 02:49:30 UTC 2011 rbrown@common-lisp.net

* Add entry for cl-unification-test.asd.

+2011-02-16 Robert Brown <robert.brown at gmail.com>

+

+ * cl-unification.asd: Add support for asdf:test-system.

+

+ * cl-unification-test.asd: File added.

+

Sat Apr 2 02:47:50 UTC 2011 rbrown@common-lisp.net

* Add cl-unification-test.asd

Make (asdf:test-system 'cl-unification) work.

+;;;; cl-unification-test.asd

+

+

+(in-package #:asdf)

+

+;; Tests implemented using the ptester framework are run at *load* time, so

+;; we tell ASDF that loading a file containing ptester code is never done.

+;; This causes ASDF to run all the tests whenever ASDF:LOAD-SYSTEM or

+;; ASDF:TEST-SYSTEM is called with argument CL-UNIFICATION-TEST.

+

+(defclass ptester-source-file (cl-source-file)

+ ()

+ (:documentation "A Common Lisp source file containing ptester code."))

+

+(defmethod operation-done-p ((operation load-op) (component ptester-source-file))

+ nil)

+

+

+(in-package #:common-lisp-user)

+

+(defpackage #:cl-unification-test-system

+ (:use #:common-lisp #:asdf))

+

+(in-package #:cl-unification-test-system)

+

+(defsystem #:cl-unification-test

+ :depends-on (:cl-unification :ptester)

+ :components

+ ((:module "test"

+ :components

+ ((:ptester-source-file "unification-tests")))))

+ :in-order-to ((test-op (test-op :cl-unification-test)))

-;;;; CL-UNIFICATION test suite. Requires Franz's util.test package on

-;;;; allegro or the ptester compatibility library on other lisps.

-#+allegro (require :tester)

-#-allegro (asdf:oos 'asdf:load-op :ptester)

+;;;; CL-UNIFICATION test suite. Requires ptester, the public version of

+;;;; Franz's util.test package.

+

+(defpackage "IT.UNIMIB.DISCO.MA.CL.EXT.DACF.UNIFICATION.TESTS"

+ (:use "CL" "UNIFY" "PTESTER")

+ (:nicknames "CL.EXT.DACF.UNIFICATION.TESTS" "UNIFY.TESTS"))

-(cl:defpackage "UNIFY.TESTS"

- (:use "CL" "UNIFY" #+allegro "UTIL.TEST" #-allegro "PTESTER"))

Sat Apr 2 02:37:58 UTC 2011 rbrown@common-lisp.net

* Make sure that classes referenced in #T forms are defined

before the forms are read. This fixes compilation of

file unification-tests.lisp.

+(eval-when (:compile-toplevel :load-toplevel :execute)

+

+)

+

Tue Mar 29 23:22:33 UTC 2011 mantoniotti@common-lisp.net

* Copyright dates updated.

-Copyright (c) 2004-2009 Marco Antoniotti[_^M_][_$_]

+Copyright (c) 2004-2011 Marco Antoniotti[_^M_][_$_]

-Marco Antoniotti (c) 2004-2008

+Marco Antoniotti (c) 2004-2011

Tue Mar 29 23:20:53 UTC 2011 mantoniotti@common-lisp.net

* ChangeLog updated.

+2011-01-18 author <author at paniscia.local>

+

+ * unifier.lisp:

+ After a careful reading of PAIP fixed a very subtle bug in VAR-UNIFY

+ that prevented the correct unification of:

+

+ (?x ?y a)

+

+ with

+

+ (?y ?x ?x)

+

+ * substitutions.lisp:

+ Added debugging functions DUMP-FRAME and DUMP-ENVIRONMENT.

+

+ * .cvsignore: Added .cvsignore file.

+

+2009-12-17 author <author at paniscia.local>

+

+ * ChangeLog: ChangeLog updated.

+

+ * lib-dependent/cl-ppcre-template.asd: Initial checkin.

+

+ * lib-dependent/cl-ppcre-template.lisp:

+ Patched to use Cl-PPCRE:SCAN-TO-STRINGS (thanks to Pixel // pinterface [a] gmail dot com).

+

+ * unifier.lisp: Minor cosmetic changes.

+

+ * unification-package.lisp: Exported MATCHF-CASE.

+

+ * templates-hierarchy.lisp:

+ Fixed a couple of problems with some accessors in the NUMBER,

+ STRUCTURE-OBJECT and STANDARD-OBJECT templates.

+

+ * match-block.lisp: Added MATCHF* macros.

+

Tue Mar 29 22:59:37 UTC 2011 mantoniotti@common-lisp.net

* Added debugging functions DUMP-FRAME and DUMP-ENVIRONMENT.

+;;;---------------------------------------------------------------------------

+;;; Simple debugging.

+(defun dump-frame (f &optional (out *standard-output*))

+ (declare (type frame f))

+ (terpri out)

+ (loop for (var . value) in (frame-bindings f)

+ do (format out "~A~VT= ~A~%" var 8 value))

+ )

+

+(defun dump-environment (env &optional (out *standard-output*))

+ (declare (type environment env))

+ (map nil #'(lambda (f) (dump-frame f out)) (environment-frames env)))

Tue Jun 15 03:21:37 UTC 2010 pix@kepibu.org

* Pull variable binding out of %match-expander

I'd like to tell you this is part of a plan to simplify %match-expander, but in

all honesty, the only reason I'm doing it is because I found myself thinking

with-unification-variables would be a handy macro while working on a private

extension to cl-unification, and I didn't want to duplicate the code.

+(defmacro with-unification-variables ((&rest variables) environment &body body)[_^M_][_$_]

+ "Execute body with variables bound to their values in environment."[_^M_][_$_]

+ (flet ((variable-bindings (v)[_^M_][_$_]

+ `((,v (find-variable-value ',v ,environment))[_^M_][_$_]

+ (,(clean-unify-var-name v) ,v))))[_^M_][_$_]

+ `(let* ,(mapcan #'variable-bindings variables)[_^M_][_$_]

+ (declare (ignorable ,@(mapcar #'clean-unify-var-name variables)))[_^M_][_$_]

+ ,@body)))[_^M_][_$_]

+[_^M_][_$_]

- (bind-variable (v)[_^M_][_$_]

- `((,v (find-variable-value ',v ,match-environment))[_^M_][_$_]

- (,(clean-unify-var-name v) ,v)))[_^M_][_$_]

- (let* ,(mapcan #'bind-variable variables)[_^M_][_$_]

- (declare (ignorable ,@variables ,@(mapcar #'clean-unify-var-name variables)))[_^M_][_$_]

+ (with-unification-variables ,variables ,match-environment[_^M_][_$_]

Sun Feb 7 08:42:39 UTC 2010 pix@kepibu.org

* Marginally more straightforward?

- clause[_^M_][_$_]

+ (munge-clause clause)[_^M_][_$_]

- ,@(mapcar (lambda (c) (expand-clause (munge-clause c))) match-clauses)[_^M_][_$_]

+ ,@(mapcar #'expand-clause match-clauses)[_^M_][_$_]

Sun Feb 7 07:40:23 UTC 2010 pix@kepibu.org

* Declare ftype of find-variable-value and v? properly

-(declaim (ftype (function (symbol environment &optional boolean)

+(declaim (ftype (function (symbol &optional environment boolean)

+ (values t boolean))

+ find-variable-value)

+ (ftype (function (symbol environment &optional boolean)

- find-variable-value

Sun Feb 7 07:33:38 UTC 2010 pix@kepibu.org

* Fix export of lib-dependent symbols

-

-;;;;===========================================================================

-;;;; Simple stuff that should be built in ASDF.

-

-(defclass asdf-system-definition-file (asdf:cl-source-file) ())

-(defmethod source-file-type ((c asdf-system-definition-file) (s module)) "asd")

-

+(defclass load-only-file (cl-source-file)

+ ((last-loaded :accessor load-date :initform nil)))

+(defmethod operation-done-p ((op compile-op) (component load-only-file))

+ t)

+(defmethod perform :around ((op compile-op) (component load-only-file))

+ nil)

+(defmethod operation-done-p ((op load-op) (component load-only-file))

+ (and (load-date component)

+ (>= (load-date component) (file-write-date (component-pathname component)))))

+(defmethod perform ((op load-op) (component load-only-file))

+ (prog1 (load (component-pathname component))

+ (setf (load-date component)

+ (file-write-date (component-pathname component)))))

- (:file "apply-substitution")

- #+asdf-with-optional-dependencies

- (:module "lib-dependent"

- :pathname "lib-dependent"

- :depends-on ("templates-hierarchy" "unifier")

- :components ((:file "cl-ppcre-template"

- :depends-on (cl-ppcre))

- ))

- #-asdf-with-optional-dependencies

- (asdf-system-definition-file

- "cl-unification-lib")

- ))

+ (:file "apply-substitution")))

- :components ((:module "lib-dependent"

+ :components ((:load-only-file "unification-package")

+ (:module "lib-dependent"

- :components ((:module "lib-dependent"

+ :components ((:load-only-file "unification-package")

+ (:module "lib-dependent"

Sun Feb 7 07:30:06 UTC 2010 pix@kepibu.org

* Specialization on the second arg of print-object is not allowed

-(defmethod print-object ((template template) (stream stream))

+(defmethod print-object ((template template) stream)

Fri Feb 5 09:30:48 UTC 2010 pix@kepibu.org

* Whoops. Typo in test.

- (test-error (match ('(x) '(xx) :errorp nil)

+ (test-error (match ('(x) '(x) :errorp nil)

Fri Feb 5 09:04:00 UTC 2010 pix@kepibu.org

* Create a named-readtable if the named-readtables library is also loaded

Because (in-readtable ...) is a beautiful thing.

+#+asdf-system-connections

+(asdf:defsystem-connection cl-unification+named-readtables

+ :requires (:cl-unification :named-readtables)

+ :components ((:module "lib-dependent"

+ :components ((:file "named-readtable")))))

+

+;;;; Set up a named-readtable

+(in-package "CL.EXT.DACF.UNIFICATION")

+

+(named-readtables:defreadtable template-readtable

+ (:dispatch-macro-char #\# #\t #'|sharp-T-reader|)

+ (:merge :common-lisp))

+

+ #+named-readtables

+ (:export

+ "TEMPLATE-READTABLE")

Fri Feb 5 09:02:42 UTC 2010 pix@kepibu.org

* Add (enable-template-reader), so it is easy to turn on the template reader

Useful when there are conflicts on #T, such as with closure-html.

+ (:file "template-reader")

+;;; Setting up the reader macro.

+(in-package "CL.EXT.DACF.UNIFICATION")

+

+;;; 20080711 MA:

+;;; Reverted to the old version with MAKE-LOAD-FORM added. Template

+;;; objects are created at read-time.

+

+(defun |sharp-T-reader| (stream subchar arg)

+ (declare (ignore subchar arg))

+ (let ((spec (read stream t nil t)))

+ (typecase spec

+ (null (make-template nil spec))

+ (cons (make-template (first spec) spec))

+ (t (make-template spec spec)))))

+

+(defmethod make-load-form ((x template) &optional env)

+ (make-load-form-saving-slots x :environment env))

+

+

+#||

+;;; Version with more 'macro-like' behavior. The previous version

+;;; created an object at read-time, which may cause problems with

+;;; MAKE-LOAD-FORMs, constant-ness etc etc.

+;;;

+;;; 20080713 MA

+;;; Removed because it was not working well with nested templates.

+;;; Reverted to the original one plus MAKE-LOAD-FORM.

+

+(defun |sharp-T-reader| (stream subchar arg)

+ (declare (ignore subchar arg))

+ (let ((spec (read stream t nil t)))

+ (typecase spec

+ (null `(make-template nil ',spec))

+ (cons `(make-template ',(first spec) ',spec))

+ (t `(make-template ',spec ',spec)))

+ ))

+||#

+

+(eval-when (:load-toplevel :execute)

+ (set-dispatch-macro-character #\# #\T '|sharp-T-reader|))

+

+

+#|| Useless with the read time templates and MAKE-LOAD-FORM.

+

+(defun rewrite-template-spec (spec)

+ "Rewrites a template specification.

+The rewriting simply makes sure that sub-templates are created as needed.

+The result is either the SPEC itself or an appropriate call to LIST."

+

+ (typecase spec

+ (atom `',spec)

+ (cons (destructuring-bind (head &rest tail)

+ spec

+ (case head

+ (quote spec)

+ (make-template `(make-template ,(first tail)

+ ,(rewrite-template-spec (second (second tail)))))

+ (t `(list ',head ,@(mapcar #'rewrite-template-spec tail)))

+ )))

+ (t `',spec)))

+

+||#

+

+(defmacro enable-template-reader ()

+ `(eval-when (:compile-toplevel :load-toplevel :execute)

+ (setf *readtable* (copy-readtable *readtable*))

+ (set-dispatch-macro-character #\# #\T '|sharp-T-reader|)))

-;;; Setting up the reader macro.

-

-;;; 20080711 MA:

-;;; Reverted to the old version with MAKE-LOAD-FORM added. Template

-;;; objects are created at read-time.

-

-(defun |sharp-T-reader| (stream subchar arg)

- (declare (ignore subchar arg))

- (let ((spec (read stream t nil t)))

- (typecase spec

- (null (make-template nil spec))

- (cons (make-template (first spec) spec))

- (t (make-template spec spec)))))

-

-(defmethod make-load-form ((x template) &optional env)

- (make-load-form-saving-slots x :environment env))

-

-

-#||

-;;; Version with more 'macro-like' behavior. The previous version

-;;; created an object at read-time, which may cause problems with

-;;; MAKE-LOAD-FORMs, constant-ness etc etc.

-;;;

-;;; 20080713 MA

-;;; Removed because it was not working well with nested templates.

-;;; Reverted to the original one plus MAKE-LOAD-FORM.

-

-(defun |sharp-T-reader| (stream subchar arg)

- (declare (ignore subchar arg))

- (let ((spec (read stream t nil t)))

- (typecase spec

- (null `(make-template nil ',spec))

- (cons `(make-template ',(first spec) ',spec))

- (t `(make-template ',spec ',spec)))

- ))

-||#

-

-(eval-when (:load-toplevel :execute)

- (set-dispatch-macro-character #\# #\T '|sharp-T-reader|))

-

-

-#|| Useless with the read time templates and MAKE-LOAD-FORM.

-

-(defun rewrite-template-spec (spec)

- "Rewrites a template specification.

-The rewriting simply makes sure that sub-templates are created as needed.

-The result is either the SPEC itself or an appropriate call to LIST."

-

- (typecase spec

- (atom `',spec)

- (cons (destructuring-bind (head &rest tail)

- spec

- (case head

- (quote spec)

- (make-template `(make-template ,(first tail)

- ,(rewrite-template-spec (second (second tail)))))

- (t `(list ',head ,@(mapcar #'rewrite-template-spec tail)))

- )))

- (t `',spec)))

-

-||#

- [_$_]

-

-

+ "ENABLE-TEMPLATE-READER"

Fri Feb 5 08:58:50 UTC 2010 pix@kepibu.org

* Export new MATCH* macros.

+ "MATCH-COND"

+ "MATCHF-COND"

+ "MATCH-ECASE"

+ "MATCHF-ECASE"

Fri Feb 5 03:21:40 UTC 2010 pix@kepibu.org

* Unified docstrings.

+(defmacro %set-documentation ((&rest symbols) docstring)[_^M_][_$_]

+ `(eval-when (:load-toplevel :execute)[_^M_][_$_]

+ (mapcar (lambda (fn) (setf (documentation fn 'function) ,docstring))[_^M_][_$_]

+ ',symbols)))[_^M_][_$_]

+[_^M_][_$_]

- "Sets up a lexical environment to evaluate FORMS after an unification.[_^M_][_$_]

-[_^M_][_$_]

-MATCH unifies a TEMPLATE and an OBJECT and then sets up a lexical[_^M_][_$_]

-environment where the variables present in the template are bound[_^M_][_$_]

-lexically. Note that both variable names '?FOO' and 'FOO' are bound[_^M_][_$_]

-for convenience.[_^M_][_$_]

-[_^M_][_$_]

-The MATCH form returns the values returned by the evaluation of the[_^M_][_$_]

-last of the FORMS.[_^M_][_$_]

-[_^M_][_$_]

-If ERRORP is non-NIL (the default) then the form raises a[_^M_][_$_]

-UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,[_^M_][_$_]

-whose default is NIL is returned. (Note that UNIFICATION-FAILUREs[_^M_][_$_]

-raising from the evaluation of FORMS will also be caught and handled[_^M_][_$_]

-according to ERRORP settings.)[_^M_][_$_]

-[_^M_][_$_]

-If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED[_^M_][_$_]

-is set up around the matching code.[_^M_][_$_]

-"[_^M_][_$_]

- "Sets up a lexical environment to evaluate FORMS after an unification.[_^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_][_$_]

+[_^M_][_$_]

+(%set-documentation[_^M_][_$_]

+ (match matchf)[_^M_][_$_]

+ "Sets up a lexical environment to evaluate FORMS after an unification.[_^M_][_$_]

-MATCHF unifies a TEMPLATE and an OBJECT and then sets up a lexical[_^M_][_$_]

+MATCH and MATCHF unify a TEMPLATE and an OBJECT and then set up a lexical[_^M_][_$_]

-The MATCHF form returns the values returned by the evaluation of the[_^M_][_$_]

+MATCH and MATCHF forms return the values returned by the evaluation of the[_^M_][_$_]

-raising from the evaluation of FORMS will also be caught and handled[_^M_][_$_]

+raising from the evaluation of FORMS will /not/ be caught and handled[_^M_][_$_]

-If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED[_^M_][_$_]

-is set up around the matching code.[_^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_][_$_]

+A surrounding BLOCK named NAMED is set up around the matching code.")[_^M_][_$_]

- "A combination of COND and MATCH."[_^M_][_$_]

- "A combination of COND and MATCHF."[_^M_][_$_]

- "MATCHING sets up a COND-like environment for multiple template matching clauses.[_^M_][_$_]

-[_^M_][_$_]

-The syntax of MATCHING comprises a number of clauses of the form[_^M_][_$_]

-[_^M_][_$_]

- <clause> ::= <regular-clause> | <default-clause>[_^M_][_$_]

- <regular-clause> ::= ((<template> <form>) &body <forms>)[_^M_][_$_]

- <default-clause> ::= (t &body <forms>)[_^M_][_$_]

- | (otherwise &body <forms>)[_^M_][_$_]

-<form> and <forms> are regular Common Lisp forms.[_^M_][_$_]

-<template> is a unification template.[_^M_][_$_]

-[_^M_][_$_]

-The full syntax of MATCHING is[_^M_][_$_]

-[_^M_][_$_]

- matching (&key errorp default-substitution) <clauses>[_^M_][_$_]

-[_^M_][_$_]

-Each clause evaluates its forms in an environment where the variables[_^M_][_$_]

-present in the template are bound lexically. Note that both variable[_^M_][_$_]

-names '?FOO' and 'FOO' are bound for convenience.[_^M_][_$_]

-[_^M_][_$_]

-The values returned by the MATCHING form are those of the last form in[_^M_][_$_]

-the first clause that satisfies the match test.[_^M_][_$_]

-[_^M_][_$_]

-If ERRORP is non-NIL then if none of the regular clauses matches, then[_^M_][_$_]

-an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of[_^M_][_$_]

-any default clause. Otherwise, the default clause behaves as a[_^M_][_$_]

-standard COND default clause. The default value of ERRORP is NIL.[_^M_][_$_]

-"[_^M_][_$_]

-(defmacro match-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))[_^M_][_$_]

- &body clauses)[_^M_][_$_]

- "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.[_^M_][_$_]

-[_^M_][_$_]

-The syntax of MATCH-CASE comprises a number of clauses of the form[_^M_][_$_]

+(%set-documentation[_^M_][_$_]

+ (match-cond matchf-cond matching)[_^M_][_$_]

+ "MATCH-COND, MATCHF-COND, and MATCHING set up a COND-like environment for[_^M_][_$_]

+multiple template matching clauses.[_^M_][_$_]

+Their syntax comprises a number of clauses of the form[_^M_][_$_]

- <regular-clause> ::= (<template> &body <forms>)[_^M_][_$_]

+ <regular-clause> ::= ((<template> <form>) &body <forms>)[_^M_][_$_]

-The full syntax of MATCH-CASE is[_^M_][_$_]

-[_^M_][_$_]

- match-case <object> (&key errorp default-substitution) <clauses>[_^M_][_$_]

+The full syntax is[_^M_][_$_]

+ match-cond <clauses>[_^M_][_$_]

+ matchf-cond <clauses>[_^M_][_$_]

+ matching (&key errorp default-substitution named) <clauses>[_^M_][_$_]

-The values returned by the MATCH-CASE form are those of the last form in[_^M_][_$_]

+The values returned by the macros are those of the last form in[_^M_][_$_]

-standard CASE default clause. The default value of ERRORP is NIL.[_^M_][_$_]

-"[_^M_][_$_]

+standard COND default clause. The default value of ERRORP is NIL.[_^M_][_$_]

+")[_^M_][_$_]

+[_^M_][_$_]

+[_^M_][_$_]

+(defmacro match-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))[_^M_][_$_]

+ &body clauses)[_^M_][_$_]

- "MATCHF-CASE sets up a CASE-like environment for multiple template matching clauses.[_^M_][_$_]

-[_^M_][_$_]

-The syntax of MATCHF-CASE comprises a number of clauses of the form[_^M_][_$_]

-[_^M_][_$_]

- <clause> ::= <regular-clause> | <default-clause>[_^M_][_$_]

- <regular-clause> ::= (<template> &body <forms>)[_^M_][_$_]

- <default-clause> ::= (t &body <forms>)[_^M_][_$_]

- | (otherwise &body <forms>)[_^M_][_$_]

-<form> and <forms> are regular Common Lisp forms.[_^M_][_$_]

-<template> is a unification template.[_^M_][_$_]

-[_^M_][_$_]

-The full syntax of MATCHF-CASE is[_^M_][_$_]

-[_^M_][_$_]

- matchf-case <object> (&key errorp default-substitution) <clauses>[_^M_][_$_]

-[_^M_][_$_]

-Each clause evaluates its forms in an environment where the variables[_^M_][_$_]

-present in the template are bound lexically. Note that both variable[_^M_][_$_]

-names '?FOO' and 'FOO' are bound for convenience.[_^M_][_$_]

-[_^M_][_$_]

-The values returned by the MATCH-CASE form are those of the last form in[_^M_][_$_]

-the first clause that satisfies the match test.[_^M_][_$_]

-[_^M_][_$_]

-If ERRORP is non-NIL then if none of the regular clauses matches, then[_^M_][_$_]

-an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of[_^M_][_$_]

-any default clause. Otherwise, the default clause behaves as a[_^M_][_$_]

-standard CASE default clause. The default value of ERRORP is NIL.[_^M_][_$_]

-[_^M_][_$_]

-MATCHF-CASE behaves like MATCH-CASE, but the patterns are not[_^M_][_$_]

-evaluated (i.e., it relies on MATCHF instead of MATCH to construct the[_^M_][_$_]

-macro expansion.[_^M_][_$_]

-"[_^M_][_$_]

+(%set-documentation[_^M_][_$_]

+ (match-case match-ecase matchf-case matchf-ecase)[_^M_][_$_]

+ "MATCH-CASE, MATCH-ECASE, MATCHF-CASE, and MATCHF-ECASE set up a CASE-like[_^M_][_$_]

+environment for multiple template matching clauses.[_^M_][_$_]

+[_^M_][_$_]

+Their syntax comprises a number of clauses of the form[_^M_][_$_]

+ <clause> ::= <regular-clause> | <default-clause>[_^M_][_$_]

+ <regular-clause> ::= (<template> &body <forms>)[_^M_][_$_]

+ <default-clause> ::= (t &body <forms>)[_^M_][_$_]

+ | (otherwise &body <forms>)[_^M_][_$_]

+<form> and <forms> are regular Common Lisp forms.[_^M_][_$_]

+<template> is a unification template.[_^M_][_$_]

+[_^M_][_$_]

+The full syntax is[_^M_][_$_]

+ match-case (<object> &key default-substitution named errorp) <clauses>[_^M_][_$_]

+ match-ecase (<object> &key default-substitution named) <clauses>[_^M_][_$_]

+ matchf-case (<object> &key default-substitution named errorp) <clauses>[_^M_][_$_]

+ matchf-ecase (<object> &key default-substitution named) <clauses>[_^M_][_$_]

+[_^M_][_$_]

+Each clause evaluates its forms in an environment where the variables[_^M_][_$_]

+present in the template are bound lexically. Note that both variable[_^M_][_$_]

+names '?FOO' and 'FOO' are bound for convenience.[_^M_][_$_]

+[_^M_][_$_]

+The values returned by the macros are those of the last form in[_^M_][_$_]

+the first clause that satisfies the match test.[_^M_][_$_]

+[_^M_][_$_]

+MATCHF-ECASE and MATCHF-CASE behave like MATCH-ECASE and MATCH-CASE, but the[_^M_][_$_]

+patterns are not evaluated (i.e., they rely on MATCHF instead of MATCH to[_^M_][_$_]

+construct the macro expansion).[_^M_][_$_]

+")[_^M_][_$_]

+[_^M_][_$_]

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.

-(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_][_$_]

-(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_][_$_]

- (match-named nil)[_^M_][_$_]

- (substitution '(make-empty-environment))[_^M_][_$_]

+ (named nil)[_^M_][_$_]

+ (match-named nil match-named-p)[_^M_][_$_]

+ (substitution nil)[_^M_][_$_]

- (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_][_$_]

- (match-named nil)[_^M_][_$_]

- (substitution '(make-empty-environment))[_^M_][_$_]

+ (named nil)[_^M_][_$_]

+ (match-named nil match-named-p)[_^M_][_$_]

+ (substitution nil)[_^M_][_$_]

- (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_][_$_]

- ())[_^M_][_$_]

+ ()[_^M_][_$_]

+ (:default-initargs[_^M_][_$_]

+ :format-control "Non exhaustive matching."))[_^M_][_$_]

+[_^M_][_$_]

+(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_][_$_]

- (default-substitution[_^M_][_$_]

- (make-empty-environment))[_^M_][_$_]

- (matching-named nil))[_^M_][_$_]

+ default-substitution[_^M_][_$_]

+ (named nil)[_^M_][_$_]

+ (matching-named nil matching-named-p))[_^M_][_$_]

- (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_][_$_]

- `(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_][_$_]

- (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_][_$_]

+(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_][_$_]

-(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_][_$_]

- (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_][_$_]

+(defun make-expanded-environment (base-env)

+ (make-environment :frames (cons (make-frame) (environment-frames base-env))))

+

Thu Feb 4 07:31:47 UTC 2010 pix@kepibu.org

* Duplicate nested match-case tests for matchf-case.

+(defun nested-matchf-cases (input)

+ (matchf-case (input)

+ ((:a ?a :b #T(list &rest ?bs))

+ (loop for b in ?bs

+ collect (matchf-case (b)

+ ((:c ?c) ?c)

+ ((:d ?d) ?d)

+ (otherwise (error 'inner-error)))))

+ (otherwise (error 'outer-error))))

+

-

-

- (test-error (match ('(x) '(x) :errorp nil)

+ (test-error (nested-matchf-cases '(:a 42 :b 33)) :condition-type 'outer-error)

+ (test-error (nested-matchf-cases '(:a 42 :b (33 42))) :condition-type 'inner-error)

+ (test '(42 43 44) (nested-matchf-cases '(:a 42 :b ((:d 42) (:c 43) (:c 44))))

+ :test #'equal)

+

+ (test-error (match ('(x) '(xx) :errorp nil)

Thu Feb 4 07:20:04 UTC 2010 pix@kepibu.org

* Make "inner-error" and "outer-error" proper conditions.

+(define-condition inner-unification-failure (unification-failure) ()

+ (:default-initargs :format-control "Inner unification-failure."))

+(define-condition inner-error (simple-error) ()

+ (:default-initargs :format-control "Inner error."))

+(define-condition outer-error (simple-error) ()

+ (:default-initargs :format-control "Outer error."))

- (otherwise (error "error-inner")))))

- (otherwise (error "error-outer"))))

-

-(define-condition inner-error (unification-failure) ()

- (:default-initargs :format-control "Inner error."))

+ (otherwise (error 'inner-error)))))

+ (otherwise (error 'outer-error))))

- (test-error (nested-match-cases '(:a 42 :b 33)) :announce t)

+ (test-error (nested-match-cases '(:a 42 :b 33)) :condition-type 'outer-error)

- (test-error (nested-match-cases '(:a 42 :b (33 42))) :announce t)

+ (test-error (nested-match-cases '(:a 42 :b (33 42))) :condition-type 'inner-error)

- (error 'inner-error))

- :condition-type 'inner-error)

+ (error 'inner-unification-failure))

+ :condition-type 'inner-unification-failure)

- (error 'inner-error))

- :condition-type 'inner-error)

+ (error 'inner-unification-failure))

+ :condition-type 'inner-unification-failure)

- (('x 'x) (error 'inner-error))

+ (('x 'x) (error 'inner-unification-failure))

- :condition-type 'inner-error)

+ :condition-type 'inner-unification-failure)

- ('(x) (error 'inner-error))

+ ('(x) (error 'inner-unification-failure))

- :condition-type 'inner-error)

+ :condition-type 'inner-unification-failure)

- ((x) (error 'inner-error))

+ ((x) (error 'inner-unification-failure))

- :condition-type 'inner-error)

+ :condition-type 'inner-unification-failure)

Wed Feb 3 09:56:58 UTC 2010 pix@kepibu.org

* Make condition printable, for easier manually stepping through tests.

-(define-condition inner-error (unification-failure) ())

+(define-condition inner-error (unification-failure) ()

+ (:default-initargs :format-control "Inner error."))

Wed Feb 3 09:53:59 UTC 2010 pix@kepibu.org

* These are no longer failures. Woo!

- :condition-type 'inner-error

- :known-failure t)

+ :condition-type 'inner-error)

- :condition-type 'inner-error

- :known-failure t)

+ :condition-type 'inner-error)

- :condition-type 'inner-error

- :known-failure t)

+ :condition-type 'inner-error)

- :condition-type 'inner-error

- :known-failure t)

+ :condition-type 'inner-error)

Mon Jan 25 07:38:54 UTC 2010 pix@kepibu.org

* Moar tests!

+(define-condition inner-error (unification-failure) ())

+

+

+ (test-error (match ('(x) '(x) :errorp nil)

+ (error 'inner-error))

+ :condition-type 'inner-error

+ :known-failure t)

+

+ (test-error (matchf ((x) '(x) :errorp nil)

+ (error 'inner-error))

+ :condition-type 'inner-error

+ :known-failure t)

+

+ (with-tests (:name "final t-or-otherwise")

+ (test :success (matching ()

+ (('x 'y) :fail)

+ (t :success)))

+ (test :success (matching ()

+ (('x 'y) :fail)

+ (otherwise :success)))

+ (test :success (match-case ('x)

+ ('y :fail)

+ (t :success)))

+ (test :success (match-case ('x)

+ ('y :fail)

+ (otherwise :success)))

+ (test :success (matchf-case ('(x))

+ ((y) :fail)

+ (t :success)))

+ (test :success (matchf-case ('(x))

+ ((y) :fail)

+ (otherwise :success))))

+

+ (test-error (matching ()

+ (('x 'y) :fail)

+ (('x 'x) (error 'inner-error))

+ (('?x 'x) x))

+ :condition-type 'inner-error)

+

+ (test-error (match-case ('(x))

+ ('(y) :fail)

+ ('(x) (error 'inner-error))

+ ('(?x) x))

+ :condition-type 'inner-error

+ :known-failure t)

+

+ (test-error (matchf-case ('(x))

+ ((y) :fail)

+ ((x) (error 'inner-error))

+ ((?x) x))

+ :condition-type 'inner-error

+ :known-failure t)

+

+ (test 'sym (match-case ('(sym))

+ ('(a) :fail)

+ ('(b) :fail)

+ ('(?x) x)))

+

+ (test 'sym (matchf-case ('(sym))

+ ((a) :fail)

+ ((b) :fail)

+ ((?x) x)))

Mon Jan 25 07:38:27 UTC 2010 pix@kepibu.org

* Consider unexpected errors as test failures

...why is this not default behavior?

+;; nil seems like a lousy default for this

+(setf *error-protect-tests* t)

+

Mon Jan 25 07:03:27 UTC 2010 pix@kepibu.org

* (cond (a b) (c d) nil) isn't really valid

- ,(when default-clause (cons t (cdr default-clause)))))))[_^M_][_$_]

+ ,@(when default-clause `((t ,@(cdr default-clause))))))))[_^M_][_$_]

Sat Jan 23 00:53:33 UTC 2010 pix@kepibu.org

* How did .clbuild-skip-update even get /in/ the repo?

Sat Jan 23 00:31:24 UTC 2010 pix@kepibu.org

* Make tests file loadable

-;;;; CL-UNIFICATION test suite. Requires Franz's util.test package.

+;;;; CL-UNIFICATION test suite. Requires Franz's util.test package on

+;;;; allegro or the ptester compatibility library on other lisps.

+#+allegro (require :tester)

+#-allegro (asdf:oos 'asdf:load-op :ptester)

- (:use "CL" "UNIFY" "UTIL.TEST"))

+ (:use "CL" "UNIFY" #+allegro "UTIL.TEST" #-allegro "PTESTER"))

Sat Jan 23 00:19:32 UTC 2010 pix@kepibu.org

* DTRT when asdf-system-connections is available

+(when (asdf:find-system 'asdf-system-connections nil)

+ (asdf:oos 'asdf:load-op 'asdf-system-connections))

+

+#+asdf-system-connections

+(asdf:defsystem-connection cl-unification+cl-ppcre

+ :requires (:cl-ppcre :cl-unification)

+ :components ((:module "lib-dependent"

+ :components ((:file "cl-ppcre-template")))))

+

Thu Jan 21 01:56:47 UTC 2010 pix@kepibu.org

* Rather than a new UNIFY** function, make UNIFY* work that way

Let errors which are not UNIFICATION-FAILUREs find their way out of UNIFY*.

- (unify** ,template ,object ,substitution))[_^M_][_$_]

+ (unify* ,template ,object ,substitution))[_^M_][_$_]

- (ignore-errors (unify a b env)))

-

-(defun unify** (a b &optional (env (make-empty-environment)))

Wed Jan 20 08:28:50 UTC 2010 pix@kepibu.org

* Can't IN-PACKAGE without a previous DEFPACKAGE.

+(cl:defpackage "UNIFY.TESTS"

+ (:use "CL" "UNIFY" "UTIL.TEST"))

-(use-package "UNIFY")

-(use-package "UTIL.TEST")

-

Wed Jan 20 08:27:09 UTC 2010 pix@kepibu.org

* Handle :case-sensitive properly

If the first clause doesn't match due to mismatched case, it would

roll down to the second clause, causing case-differing strings to

erroneously match. By checking for case again, we can avoid this.

Note, however, that this does not fix the similar but unrelated

inconsistent usage of *unify-string-case-sensitive-p* and

*unify-string-case-insensitive-p* (the former being used in the code

and the latter appearing in documentation). That bug will remain

until the canonical form is decided upon.

- ((char-equal a b)

+ ((and (not case-sensitive) (char-equal a b))

- ((string-equal a b)

+ ((and (not case-sensitive) (string-equal a b))

Wed Jan 20 08:09:59 UTC 2010 pix@kepibu.org

* Fix typo (connot -> cannot)

- :format-control "Connot unify two different characters: ~S ~S."

+ :format-control "Cannot unify two different characters: ~S ~S."

- :format-control "Connot unify two different strings: ~S ~S."

+ :format-control "Cannot unify two different strings: ~S ~S."

Fri Jan 15 08:55:05 UTC 2010 pix@kepibu.org

* Redefine MATCH-CASE in terms of MATCHING

This both greatly simplifies the MATCH-CASE macro as well as its expansion.

HOWEVER, this version is *NOT* 100% compatible with the previous version.

Specifically, UNIFICATION-FAILUREs signalled from within clause-forms will /not/

cause the next unification clause to be attempted, but will instead propogate

outward as the -case name suggests they should.

That is,

-;;; match-case --[_^M_][_$_]

-;;; Implementation provided by Peter Scott.[_^M_][_$_]

-;;;[_^M_][_$_]

-;;; Notes:[_^M_][_$_]

-;;;[_^M_][_$_]

-;;; [MA 20071109][_^M_][_$_]

-;;; The construction of the inner MATCH clauses could be done[_^M_][_$_]

-;;; more intelligently by supplying :ERRORP NIL, thus avoiding the[_^M_][_$_]

-;;; HANDLER-CASEs, which are quite expensive. Any takers?[_^M_][_$_]

-[_^M_][_$_]

- (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 (match (,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_][_$_]

+ (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_][_$_]