darcs - cl-unification

repos / cl-unification / headfilediff

Instructions updated. --> to head

/INSTALLATION

Ignoring non-repository paths: /INSTALLATION

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

* Added TIMESTAMP.

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

* Copyright updated.

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

* Copyright updated.

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.

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

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

Change the documentation.

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

* 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.

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

* Updated copyright info and a News.

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

* ChangeLog updated.

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.

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

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

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

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

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

* Acknowledgements updated.

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.

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

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

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

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

* Add cl-unification-test.asd

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

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.

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

* Copyright dates updated.

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

* ChangeLog updated.

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

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

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.

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

* Marginally more straightforward?

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

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

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

* Fix export of lib-dependent symbols

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

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

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

* Whoops. Typo in test.

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.

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.

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

* Export new MATCH* macros.

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

* Unified docstrings.

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.

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

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

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

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

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

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

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

* These are no longer failures. Woo!

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

* Moar tests!

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

* Consider unexpected errors as test failures

...why is this not default behavior?

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

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

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

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

* DTRT when asdf-system-connections is available

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*.

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

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

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.

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

* Fix typo (connot -> cannot)

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,

(ignore-errors

(match-case ("foo")

("foo" (error 'unification-failure ...))

(t :default)))

=> :default ;; before patch

=> nil, #<unification-failure> ;; after patch

Fri Jan 15 08:49:26 UTC 2010 pix@kepibu.org

* Only use one variable to store the unification environment in MATCHING

Because of the way MATCHING expands, and what UNIFY* returns, each

(setf #:env (unify* ...))

call will do one of two things: it will set #:env to NIL or it will set #:env to

an ENVIRONMENT structure.

If #:env is set to NIL--the same value it entered the (setf) with!--the COND

will continue on to the next clause.

If #:env is set to an ENVIRONMENT structure, none of the remaining (setf)

clauses will be evaluated.

Thus, because the variable will only ever be set to a non-nil value once, this

should be perfectly safe.

Fri Jan 15 07:59:02 UTC 2010 pix@kepibu.org

* Make MATCHING agree with MATCH[F][-CASE] about the conditions of failure

Rather than skipping to the next clause on any error, UNIFICATION-FAILUREs--and

/only/ UNIFICATION-FAILUREs--skip to the next clause.

Fri Jan 15 07:48:53 UTC 2010 pix@kepibu.org

* Use &body instead of &rest for (arguably) prettier auto-indentation

Tue Jan 12 09:20:28 UTC 2010 pix@kepibu.org

* Fix (matching (otherwise ...))

(matching (otherwise ...)) expands into (cond (otherwise ...)), which

generates an unbound-variable error when executed, because COND does

not special-case OTHERWISE as CASE does.

Tue Jan 12 09:08:23 UTC 2010 pix@kepibu.org

* Extract the bits that wrap forms with bindings for template variables

In some cases, this patch swaps the order of execution of

%TEMPLATE-FOR-MATCH and COLLECT-TEMPLATE-VARS. I'm pretty sure this

doesn't have any noticable effect, but thorough testing is probably

wise.

Tue Jan 12 08:37:44 UTC 2010 pix@kepibu.org

* Use (unify* ...) rather than (ignore-errors (unify ...))

Same thing, so might as well use the convenience function.

Tue Jan 12 08:03:54 UTC 2010 pix@kepibu.org

* Extract template handling of MATCH[ING] into %TEMPLATE-FOR-MATCH

Thu Dec 17 17:02:42 UTC 2009 mantoniotti

* ChangeLog updated.

Thu Dec 17 16:57:45 UTC 2009 mantoniotti

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

Thu Dec 17 16:44:46 UTC 2009 mantoniotti

* Minor cosmetic changes.

Thu Dec 17 16:43:51 UTC 2009 mantoniotti

* Exported MATCHF-CASE.

Thu Dec 17 16:43:12 UTC 2009 mantoniotti

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

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

STRUCTURE-OBJECT and STANDARD-OBJECT templates.

Thu Dec 17 16:41:38 UTC 2009 mantoniotti

* Added MATCHF* macros.

Fri Apr 17 22:44:17 UTC 2009 mantoniotti

* ChangeLog updated.

Fri Apr 17 22:42:46 UTC 2009 mantoniotti

* System definitions files (.asd and .system) modified in order to make

System definitions files (.asd and .system) modified in order to make

dependency form CL-PPCRE optional.

Fri Apr 17 22:40:29 UTC 2009 mantoniotti

* Removed REQUIRE of CL-PPCRE. Too brittle.

Fri Apr 17 07:53:58 UTC 2009 mantoniotti

* Added a few exports and changed the actual package name (i.e., I put

Added a few exports and changed the actual package name (i.e., I put

my money where my mouth is; the "published" package name is now a

nickname).

Fri Apr 17 07:52:25 UTC 2009 mantoniotti

* Fixed a couple of snags. APPLY-SUBSTITUTION was not applied

Fixed a couple of snags. APPLY-SUBSTITUTION was not applied

recursively and it was barfing on numbers.

Current version is still incomplete, but it serves as a template for

further development.

Wed Apr 15 14:33:35 UTC 2009 mantoniotti

* ChangeLog updated.

Wed Apr 15 10:24:28 UTC 2009 mantoniotti

* Modified Files:

Modified Files:

test/unification-tests.lisp

Added Files:

lib-dependent/cl-ppcre-template.lisp

The cl-ppcre-template reuses E. Weitz's wonderful CL-PPCRE library

to provide a seamless (YMMV) reuse of regular expressions within

CL-UNIFICATION.

Wed Apr 15 10:18:59 UTC 2009 mantoniotti

* Added LAMBDA-TEMPLATE.

Wed Apr 15 10:17:48 UTC 2009 mantoniotti

* Added some functionality to extract all variables and/or all values

Added some functionality to extract all variables and/or all values

from an environment or a frame.

Wed Apr 15 10:16:24 UTC 2009 mantoniotti

* Added MATCHF (whose name may change) to simplify the

Added MATCHF (whose name may change) to simplify the

'destructuring-bind'-like syntax and behavior of the matching

facilities.

Wed Apr 15 10:14:59 UTC 2009 mantoniotti

* Dates updated.

Wed Apr 15 10:14:24 UTC 2009 mantoniotti

* Major API change to 'unify'. It now accepts keywords. Old code

Major API change to 'unify'. It now accepts keywords. Old code

shouls not be affected, but new code is now more flexible. Look the

the STRING and (new) CHARACTER methods to see how this change is

affecting the code.

Wed Apr 15 10:12:22 UTC 2009 mantoniotti

* Some 'diff' unfathomable change happened.

Wed Apr 15 10:10:25 UTC 2009 mantoniotti

* Added exports of a few symbols.

Wed Apr 15 10:06:40 UTC 2009 mantoniotti

* Fixed a few snags and added "lib-dependent" module.

Wed Apr 15 10:05:58 UTC 2009 mantoniotti

* Added some functionality and comments.

Sun Jul 13 13:36:42 UTC 2008 mantoniotti

tagged rev-1_0-cleaned-up

Sun Jul 13 13:36:42 UTC 2008 mantoniotti

* Changelog updated.

Sun Jul 13 13:33:48 UTC 2008 mantoniotti

* Added credits to a few people. Missing ones should bug the maintainer :)

Sun Jul 13 13:30:28 UTC 2008 mantoniotti

* Copyright dates updated.

Sun Jul 13 13:28:48 UTC 2008 mantoniotti

* Cleaning up.

Cleaning up.

Committing in .

Removed Files:

unification.asd unification.system

Sun Jul 13 13:26:38 UTC 2008 mantoniotti

* Clenaing up.

Clenaing up.

Committing in .

Removed Files:

templates-hierarchy-saved.lisp

Sun Jul 13 13:20:01 UTC 2008 mantoniotti

* Instructions updated.

diff -rN -u old-cl-unification-1/ACKNOWLEDGEMENTS new-cl-unification-1/ACKNOWLEDGEMENTS

--- old-cl-unification-1/ACKNOWLEDGEMENTS 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/ACKNOWLEDGEMENTS 2013-06-14 05:59:04.000000000 +0000

@@ -1,4 +1,4 @@

-Many thanks to a lot of people are due.

+A lot of pleple deserved thanks for improving CL-UNIFICATION.

The Lisp NYC group has endured presentations of this code and provided

feedback.

@@ -6,9 +6,10 @@

The following individuals have provided feedback and (precious) bug

fixes.

+Boldyrev, Ivan

+Brown, Robert

Korablin, Vladimir V.

Leuner, John

+McManus, Russell

Scott, Peter

Werner, Norman

diff -rN -u old-cl-unification-1/COPYING new-cl-unification-1/COPYING

--- old-cl-unification-1/COPYING 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/COPYING 2013-06-14 05:59:04.000000000 +0000

@@ -1,4 +1,4 @@

Permission is hereby granted, without written agreement and without

diff -rN -u old-cl-unification-1/ChangeLog new-cl-unification-1/ChangeLog

--- old-cl-unification-1/ChangeLog 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/ChangeLog 2013-06-14 05:59:04.000000000 +0000

@@ -1,4 +1,362 @@

-2007-11-09 author <author@papadopoulou-2.ydras.offices.aueb.gr>

+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.

+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

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

+ * 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>

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

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

+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.

+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.

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

+ * 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.

+2009-04-18 author <author@paniscia.local>

+ * ChangeLog: ChangeLog updated.

+ * cl-unification.system, cl-unification.asd:

+ System definitions files (.asd and .system) modified in order to make

+ dependency form CL-PPCRE optional.

+ * lib-dependent/cl-ppcre-template.system: File added.

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

+ Removed REQUIRE of CL-PPCRE. Too brittle.

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

+2009-04-18 author <author@Macintosh-9.local>

+ * cl-unification.system, cl-unification.asd:

+ System definitions files (.asd and .system) modified in order to make

+ dependency form CL-PPCRE optional.

+ * lib-dependent/cl-ppcre-template.system: File added.

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

+ Removed REQUIRE of CL-PPCRE. Too brittle.

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

+2009-04-17 author <author@Macintosh-9.local>

+ * unification-package.lisp:

+ Added a few exports and changed the actual package name (i.e., I put

+ my money where my mouth is; the "published" package name is now a

+ nickname).

+ * apply-substitution.lisp:

+ Fixed a couple of snags. APPLY-SUBSTITUTION was not applied

+ recursively and it was barfing on numbers.

+ Current version is still incomplete, but it serves as a template for

+ further development.

+2009-04-15 author <author@Macintosh-9.local>

+ * ChangeLog: ChangeLog updated.

+ * lib-dependent/cl-ppcre-template.lisp, test/unification-tests.lisp:

+ Modified Files:

+ test/unification-tests.lisp

+ Added Files:

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

+ The cl-ppcre-template reuses E. Weitz's wonderful CL-PPCRE library

+ to provide a seamless (YMMV) reuse of regular expressions within

+ CL-UNIFICATION.

+ * templates-hierarchy.lisp: Added LAMBDA-TEMPLATE.

+ * substitutions.lisp:

+ Added some functionality to extract all variables and/or all values

+ from an environment or a frame.

+ * match-block.lisp:

+ Added MATCHF (whose name may change) to simplify the

+ 'destructuring-bind'-like syntax and behavior of the matching

+ facilities.

+ * COPYING: Dates updated.

+ * unifier.lisp:

+ Major API change to 'unify'. It now accepts keywords. Old code

+ shouls not be affected, but new code is now more flexible. Look the

+ the STRING and (new) CHARACTER methods to see how this change is

+ affecting the code.

+ * variables.lisp: Some 'diff' unfathomable change happened.

+ * unification-package.lisp: Added exports of a few symbols.

+ * cl-unification.system, cl-unification.asd:

+ Fixed a few snags and added "lib-dependent" module.

+ * apply-substitution.lisp: Added some functionality and comments.

+2009-04-15 author <author@paniscia.pd.disco.unimib.it>

+ * lib-dependent/cl-ppcre-template.lisp, test/unification-tests.lisp:

+ Modified Files:

+ test/unification-tests.lisp

+ Added Files:

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

+ The cl-ppcre-template reuses E. Weitz's wonderful CL-PPCRE library

+ to provide a seamless (YMMV) reuse of regular expressions within

+ CL-UNIFICATION.

+ * templates-hierarchy.lisp: Added LAMBDA-TEMPLATE.

+ * substitutions.lisp:

+ Added some functionality to extract all variables and/or all values

+ from an environment or a frame.

+ * match-block.lisp:

+ Added MATCHF (whose name may change) to simplify the

+ 'destructuring-bind'-like syntax and behavior of the matching

+ facilities.

+ * COPYING: Dates updated.

+ * unifier.lisp:

+ Major API change to 'unify'. It now accepts keywords. Old code

+ shouls not be affected, but new code is now more flexible. Look the

+ the STRING and (new) CHARACTER methods to see how this change is

+ affecting the code.

+ * variables.lisp: Some 'diff' unfathomable change happened.

+ * unification-package.lisp: Added exports of a few symbols.

+ * cl-unification.system, cl-unification.asd:

+ Fixed a few snags and added "lib-dependent" module.

+ * apply-substitution.lisp: Added some functionality and comments.

+2008-07-13 author <author@paniscia.pd.disco.unimib.it>

+ * ChangeLog: Changelog updated.

+ * ACKNOWLEDGEMENTS:

+ Added credits to a few people. Missing ones should bug the maintainer :)

+ * README: Copyright dates updated.

+ * unification.asd, unification.system: Cleaning up.

+ Committing in .

+ Removed Files:

+ unification.asd unification.system

+ * templates-hierarchy-saved.lisp: Clenaing up.

+ Committing in .

+ Removed Files:

+ templates-hierarchy-saved.lisp

+ * INSTALLATION: Instructions updated.

+ * COPYING: Copyright dates updated.

+ * test/unification-tests.lisp: Added file.

+ * substitutions.lisp, templates-hierarchy.lisp, unification-package.lisp, variables.lisp:

+ Some modification added. Exported symbols and reverted

+ reader macro #T to construct template instances at read time.

+ Added MAKE-LOAD-FORM method for templates which should fix problem with

+ SBCL.

+ Committing in .

+ Modified Files:

+ substitutions.lisp templates-hierarchy.lisp

+ unification-package.lisp variables.lisp

+ * cl-unification.system:

+ Added explicit :source-extension to accomodate Allegro CL.

+2008-07-13 author <author@Macintosh.local>

+ * ACKNOWLEDGEMENTS:

+ Added credits to a few people. Missing ones should bug the maintainer :)

+ * README: Copyright dates updated.

+ * unification.asd, unification.system: Cleaning up.

+ Committing in .

+ Removed Files:

+ unification.asd unification.system

+ * templates-hierarchy-saved.lisp: Cleaning up.

+ Committing in .

+ Removed Files:

+ templates-hierarchy-saved.lisp

+ * INSTALLATION: Instructions updated.

+ * COPYING: Copyright dates updated.

+ * test/unification-tests.lisp: Added file.

+ * substitutions.lisp, templates-hierarchy.lisp, unification-package.lisp, variables.lisp:

+ Some modification added. Exported symbols and reverted

+ reader macro #T to construct template instances at read time.

+ Added MAKE-LOAD-FORM method for templates which should fix problem with

+ SBCL.

+ Committing in .

+ Modified Files:

+ substitutions.lisp templates-hierarchy.lisp

+ unification-package.lisp variables.lisp

+ * cl-unification.system:

+ Added explicit :source-extension to accomodate Allegro CL.

+2008-07-10 author <author@Macintosh.local>

+ * apply-substitution.lisp:

+ Removed EXPORT of APPLY-SUBSTITUTION as it is already in the DEFPACKAGE.

+2007-11-09 author <author@Macintosh.local>

+ * docs/html/index.html: Changed the position of the disclaimer.

+ * ChangeLog: ChangeLog updated.

+ * match-block.lisp:

+ Made several changes to improve MATCH-CASE (following a note from Ivan

+ Boldyrev from a long time ago), MATCHING and MATCH.

+ Else-clauses are now handled correctly (AFAICT).

+ Single variable templates in MATCH, MATCH-CASE and MATCHING clauses do

+ not need to be quoted.

+ MATCHING was generating one gensym'ed variable per clause without

+ creating an appropriate enclosing LET. This is now fixed.

+ * substitutions.lisp:

+ Changed the top comment and added a (:copier nil) option to the

+ ENVIRONMENT defstruct, as COPY-ENVIRONMENT is defined later in the

+ file.

+ * cl-unification.system, cl-unification.asd:

+ Added the new system building files with more meaningful names

+ w.r.t. the name of the library.

+ * unification.asd, unification.system:

+ Marked the two system building files as 'obsolete', before removing

+ them from the repository. The new files are prefixed by 'cl-'.

+2007-11-09 author <author@papadopoulou-2.ydras.offices.>

* match-block.lisp:

Made several changes to improve MATCH-CASE (following a note from Ivan

@@ -25,7 +383,7 @@

Marked the two system building files as 'obsolete', before removing

them from the repository. The new files are prefixed by 'cl-'.

-2007-05-21 author <author@papadopoulou-2.ydras.offices.aueb.gr>

+2007-05-21 author <author@papadopoulou-2.ydras.offices.>

* ChangeLog: ChangeLog updated.

diff -rN -u old-cl-unification-1/INSTALLATION new-cl-unification-1/INSTALLATION

--- old-cl-unification-1/INSTALLATION 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/INSTALLATION 2013-06-14 05:59:04.000000000 +0000

@@ -5,20 +5,26 @@

Issuing

- (mk:load-system "unification")

+ (mk:load-system "CL-UNIFICATION")

- (mk:compile-system "unification")

+ (mk:compile-system "CL-UNIFICATION")

will make the UNIFY package available.

There is also an ASDF system definition for those who use this system.

+Issuing

+ (asdf:oos 'asdf:load-op "CL-UNIFICATION")

+should make the library available in your environment.

If your CL implementation is ASDF-INSTALL aware, you should also be

able to just say

- (asdf-install:install "unification")

+ (asdf-install:install "CL-UNIFICATION")

provided that the package is unpacked in an ASDF-INSTALL known

directory.

diff -rN -u old-cl-unification-1/README new-cl-unification-1/README

--- old-cl-unification-1/README 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/README 2013-06-14 05:59:04.000000000 +0000

@@ -1,6 +1,6 @@

CL-UNIFICATION

The directory containing this file you are reading should contain the

code and the documentation of the CL-UNIFICATION package.

diff -rN -u old-cl-unification-1/TIMESTAMP new-cl-unification-1/TIMESTAMP

--- old-cl-unification-1/TIMESTAMP 1970-01-01 00:00:00.000000000 +0000

+++ new-cl-unification-1/TIMESTAMP 2013-06-14 05:59:04.000000000 +0000

@@ -0,0 +1 @@

+20120116

diff -rN -u old-cl-unification-1/apply-substitution.lisp new-cl-unification-1/apply-substitution.lisp

--- old-cl-unification-1/apply-substitution.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/apply-substitution.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -1,38 +1,85 @@

-;;; -*- 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.

(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.

;;;---------------------------------------------------------------------------

;;; Substitution application.

-(defgeneric apply-substitution (substitution item))

+;;; apply-substitution --

+;;;

+;;; EXCLUDE-VARS are variables that will just pass through (a list for

+;;; the time being).

+(defgeneric apply-substitution (substitution item &optional exclude-vars))

-(defmethod apply-substitution ((substitution environment) (s symbol))

+(defmethod apply-substitution ((s environment) (n number) &optional exclude-vars)

+ (declare (ignore exclude-vars))

+ n)

+(defmethod apply-substitution ((substitution environment) (s symbol)

+ &optional (exclude-vars ()))

+ (declare (type list exclude-vars))

(cond ((variable-any-p s) s)

((variablep s)

- (multiple-value-bind (val foundp)

- (find-variable-value s substitution)

- (cond (foundp val)

- (t (warn "~S is a free variable in the current environment."

- s)

- s))))

+ (if (member s exclude-vars :test #'eq)

+ s

+ (multiple-value-bind (val foundp)

+ (find-variable-value s substitution)

+ (cond (foundp (apply-substitution substitution val exclude-vars))

+ (t (warn "~S is a free variable in the current environment."

+ s)

+ s))))

+ )

(t s)))

-(defmethod apply-substitution ((substitution environment) (l cons))

- (cons (apply-substitution substitution (first l))

- (apply-substitution substitution (rest l))))

+(defmethod apply-substitution ((substitution environment) (l cons)

+ &optional (exclude-vars ()))

+ (declare (type list exclude-vars))

+ (cons (apply-substitution substitution (first l) exclude-vars)

+ (apply-substitution substitution (rest l) exclude-vars)))

-(defmethod apply-substitution ((substitution environment) (l null))

+(defmethod apply-substitution ((substitution environment) (l null)

+ &optional exclude-vars)

+ (declare (ignore exclude-vars))

'())

+;;; compose-substitions --

+;;; The definition is a direct translation of TPL's definition at page 318.

+;;; Usually these are done by directly composing and currying

+;;; functions in ML/Haskell derivatives, but that is just being "lazy".

+;;; The current definition may be too "eager", but the "correct"

+;;; semantics should be preserved.

+(defun compose-substitutions (env2 env1) ; note the order.

+ (declare (type environment env2 env1))

+ (loop for env1-frame in (environment-frames env1)

+ collect

+ (loop for (var . term) in (frame-bindings env1-frame)

+ collect (make-binding var (apply-substitution env2 term))

+ into result-bindings

+ finally (return (make-frame result-bindings)))

+ into frames

+ finally (return (make-environment :frames frames))))

+;;; ground-term --

(defun ground-term (term &optional (substitution (make-empty-environment)))

(apply-substitution substitution term))

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

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

diff -rN -u old-cl-unification-1/cl-unification-lib.asd new-cl-unification-1/cl-unification-lib.asd

--- old-cl-unification-1/cl-unification-lib.asd 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/cl-unification-lib.asd 2013-06-14 05:59:04.000000000 +0000

@@ -2,6 +2,8 @@

;;;; cl-unification-lib.asd --

;;;; ASDF system file.

+;;;;

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

(asdf:defsystem :cl-unification-lib

:author "Marco Antoniotti"

diff -rN -u old-cl-unification-1/cl-unification-test.asd new-cl-unification-1/cl-unification-test.asd

--- old-cl-unification-1/cl-unification-test.asd 1970-01-01 00:00:00.000000000 +0000

+++ new-cl-unification-1/cl-unification-test.asd 2013-06-14 05:59:04.000000000 +0000

@@ -0,0 +1,31 @@

+;;;; 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")))))

diff -rN -u old-cl-unification-1/cl-unification.asd new-cl-unification-1/cl-unification.asd

--- old-cl-unification-1/cl-unification.asd 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/cl-unification.asd 2013-06-14 05:59:04.000000000 +0000

@@ -1,18 +1,56 @@

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

;;;; cl-unification.asd --

;;;; ASDF system file.

-(asdf:defsystem cl-unification

- :author "Marco Antoniotti"

- :serial t

- :components ((:file "unification-package")

- (:file "variables")

- (:file "substitutions")

- (:file "lambda-list-parsing")

- (:file "templates-hierarchy")

- (:file "unifier")

- (:file "match-block")

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

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

+(defpackage "CL-UNIFICATION-SYSTEM" (:use "CL" "ASDF"))

+(in-package "CL-UNIFICATION-SYSTEM")

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

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

+(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)))))

+(asdf:defsystem :cl-unification

+ :author "Marco Antoniotti"

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

+ :serial t

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

+ (:file "variables")

+ (:file "substitutions")

+ (:file "lambda-list-parsing")

+ (:file "templates-hierarchy")

+ (:file "template-reader")

+ (:file "unifier")

+ (:file "match-block")

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

+#+asdf-system-connections

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

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

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

+ (:module "lib-dependent"

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

+#+asdf-system-connections

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

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

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

+ (:module "lib-dependent"

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

;;;; end of file -- cl-unification.asd --

diff -rN -u old-cl-unification-1/cl-unification.system new-cl-unification-1/cl-unification.system

--- old-cl-unification-1/cl-unification.system 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/cl-unification.system 2013-06-14 05:59:04.000000000 +0000

@@ -3,15 +3,24 @@

;;;; cl-unification.system --

;;;; MK:DEFSYSTEM system file.

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

(mk:defsystem "CL-UNIFICATION"

- :source-extension "lisp"

- :components ("unification-package"

- "variables"

- "substitutions"

- "lambda-list-parsing"

- "templates-hierarchy"

- "unifier"

- "match-block"

- "apply-substitution"))

+ :source-extension "lisp"

+ :components ("unification-package"

+ "variables"

+ "substitutions"

+ "lambda-list-parsing"

+ "templates-hierarchy"

+ "unifier"

+ "match-block"

+ "apply-substitution"

+ (:module "lib-dependent"

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

+ :components ((:subsystem "cl-ppcre-template"

+ :non-required-p t

+ )

+ ))

;;; end of file -- cl-unification.system --

diff -rN -u old-cl-unification-1/docs/html/control-flow.html new-cl-unification-1/docs/html/control-flow.html

--- old-cl-unification-1/docs/html/control-flow.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/control-flow.html 2013-06-14 05:59:04.000000000 +0000

@@ -208,7 +208,7 @@

- <h1>News</h1>

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

<p>News in chronological order, most recent on top.

</p>

@@ -218,7 +218,8 @@

Document created

</li>

</ul>

+-->

</div>

@@ -233,7 +234,7 @@

<tr>

</div>

</td>

</tr>

diff -rN -u old-cl-unification-1/docs/html/dictionary.html new-cl-unification-1/docs/html/dictionary.html

--- old-cl-unification-1/docs/html/dictionary.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/dictionary.html 2013-06-14 05:59:04.000000000 +0000

@@ -279,7 +279,7 @@

<!--

;;;

;;; Permission to use, modify, and redistribute this code is hereby

;;; granted.

@@ -314,7 +314,7 @@

- <h1>News</h1>

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

<p>News in chronological order, most recent on top.

</p>

@@ -324,7 +324,7 @@

Started the site.

</li>

</ul>

+-->

</div>

@@ -339,7 +339,7 @@

<tr>

</div>

</td>

</tr>

diff -rN -u old-cl-unification-1/docs/html/downloads.html new-cl-unification-1/docs/html/downloads.html

--- old-cl-unification-1/docs/html/downloads.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/downloads.html 2013-06-14 05:59:04.000000000 +0000

@@ -97,7 +97,7 @@

- <h1>News</h1>

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

<p>News in chronological order, most recent on top.

</p>

@@ -109,7 +109,7 @@

Started the site.

</li>

</ul>

+-->

</div>

@@ -124,7 +124,7 @@

<tr>

</div>

</td>

</tr>

diff -rN -u old-cl-unification-1/docs/html/index.html new-cl-unification-1/docs/html/index.html

--- old-cl-unification-1/docs/html/index.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/index.html 2013-06-14 05:59:04.000000000 +0000

@@ -308,7 +308,7 @@

<!--

;;;

;;; Permission to use, modify, and redistribute this code is hereby

;;; granted.

@@ -349,6 +349,8 @@

</p>

<ul>

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

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

Updated.

@@ -372,7 +374,7 @@

<tr>

</div>

</td>

</tr>

diff -rN -u old-cl-unification-1/docs/html/links.html new-cl-unification-1/docs/html/links.html

--- old-cl-unification-1/docs/html/links.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/links.html 2013-06-14 05:59:04.000000000 +0000

@@ -76,7 +76,7 @@

- <h1>News</h1>

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

<p>News in chronological order, most recent on top.

</p>

@@ -94,7 +94,8 @@

Started the site.

</li>

</ul>

+-->

</div>

@@ -109,7 +110,7 @@

<tr>

</div>

</td>

</tr>

diff -rN -u old-cl-unification-1/docs/html/mailing-lists.html new-cl-unification-1/docs/html/mailing-lists.html

--- old-cl-unification-1/docs/html/mailing-lists.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/mailing-lists.html 2013-06-14 05:59:04.000000000 +0000

@@ -55,7 +55,7 @@

<!--

;;;

;;; Permission to use, modify, and redistribute this code is hereby

;;; granted.

@@ -90,7 +90,7 @@

- <h1>News</h1>

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

<p>News in chronological order, most recent on top.

</p>

@@ -102,7 +102,7 @@

Started the site.

</li>

</ul>

+-->

</div>

@@ -117,7 +117,7 @@

<tr>

</div>

</td>

</tr>

diff -rN -u old-cl-unification-1/docs/html/string-template-class.html new-cl-unification-1/docs/html/string-template-class.html

--- old-cl-unification-1/docs/html/string-template-class.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/string-template-class.html 2013-06-14 05:59:04.000000000 +0000

@@ -122,7 +122,7 @@

<h2>Affected By:</h2>

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

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

<h2>Exceptional Situations:</h2>

diff -rN -u old-cl-unification-1/docs/html/templates.html new-cl-unification-1/docs/html/templates.html

--- old-cl-unification-1/docs/html/templates.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/templates.html 2013-06-14 05:59:04.000000000 +0000

@@ -173,7 +173,7 @@

- <h1>News</h1>

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

<p>News in chronological order, most recent on top.

</p>

@@ -183,7 +183,7 @@

Document created

</li>

</ul>

+-->

</div>

@@ -198,7 +198,7 @@

<tr>

</div>

</td>

</tr>

diff -rN -u old-cl-unification-1/docs/html/unification-dictionary.html new-cl-unification-1/docs/html/unification-dictionary.html

--- old-cl-unification-1/docs/html/unification-dictionary.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/unification-dictionary.html 2013-06-14 05:59:04.000000000 +0000

@@ -38,7 +38,7 @@

<ul>

<li><a href="unify-package.html"><i>Package</i> <b>CL.EXT.DACF.UNIFICATION</b></a>

<li><a href="unify-function.html"><i>Generic function</i> <b>UNIFY</b></a>

- <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>

<li><a href="template-class.html"><i>Class</i> <b>TEMPLATE</b></a>

<li><a href="expression-template-class.html"><i>Class</i> <b>EXPRESSION-TEMPLATE</b></a>

@@ -106,7 +106,7 @@

- <h1>News</h1>

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

<p>News in chronological order, most recent on top.

</p>

@@ -118,7 +118,7 @@

Started the page.

</li>

</ul>

+-->

</div>

@@ -133,7 +133,7 @@

<tr>

</div>

</td>

</tr>

diff -rN -u old-cl-unification-1/docs/html/unify-function.html new-cl-unification-1/docs/html/unify-function.html

--- old-cl-unification-1/docs/html/unify-function.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/unify-function.html 2013-06-14 05:59:04.000000000 +0000

@@ -163,7 +163,7 @@

</p>

<p>Two strings unify only is they are "equal", under the following

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

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

(the default) then the two strings <i>s1</i> and <i>s2</i> are

compared using STRING=, otherwise they are compared using STRING-EQUAL.

</p>

@@ -335,7 +335,7 @@

<p>MAKE-EMPTY-ENVIRONMENT, UNIFICATION-FAILURE,

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

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

*OCCURENCE-CHECK-P*.</p>

<h2>Notes:</h2>

diff -rN -u old-cl-unification-1/docs/html/unifying-substitutions.html new-cl-unification-1/docs/html/unifying-substitutions.html

--- old-cl-unification-1/docs/html/unifying-substitutions.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/unifying-substitutions.html 2013-06-14 05:59:04.000000000 +0000

@@ -162,7 +162,7 @@

- <h1>News</h1>

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

<p>News in chronological order, most recent on top.

</p>

@@ -172,7 +172,7 @@

Document created

</li>

</ul>

+-->

</div>

@@ -187,7 +187,7 @@

<tr>

</div>

</td>

</tr>

diff -rN -u old-cl-unification-1/docs/html/usci-variable.html new-cl-unification-1/docs/html/usci-variable.html

--- old-cl-unification-1/docs/html/usci-variable.html 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/docs/html/usci-variable.html 2013-06-14 05:59:04.000000000 +0000

@@ -1,6 +1,6 @@

<html>

<head>

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

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

</head>

@@ -11,7 +11,7 @@

<div class="header"

style="font-family:=Verdana,Arial,Helvetica; font-size: 18px; color: #41286f;">

- <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>

| <a href="unification-package.html" class="navigation-link">Previous</a>

@@ -33,7 +33,7 @@

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

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

<h2>Package:</h2>

@@ -56,9 +56,9 @@

<h2>Description:</h2>

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

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

behavior of the UNIFY method with signature <code>(<i>string</i> <i>string</i>)</code>.

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

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

equality of the two strings. Otherwise, the UNIFY method will use STRING-EQUAL.</p>

<h2>Affected By:</h2>

diff -rN -u old-cl-unification-1/lambda-list-parsing.lisp new-cl-unification-1/lambda-list-parsing.lisp

--- old-cl-unification-1/lambda-list-parsing.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/lambda-list-parsing.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -2,6 +2,8 @@

;;; lambda-list-parsing.lisp --

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

(in-package "UNIFY")

@@ -49,7 +51,7 @@

)

;;; The next function is really implementation-dependent, give the

-;;; definition of LAMBDA-LIST-KEYWORDS

+;;; definition of LAMBDA-LIST-KEYWORDS.

(define-condition lambda-list-parsing-error (program-error)

@@ -90,7 +92,7 @@

(&aux (parse-auxiliary-arguments (rest lambda-list)))

(&rest (parse-rest-arguments (rest lambda-list)))

(otherwise

- (warn "Keyword ~A is implementation dependent.~@

+ (warn "Keyword ~A is implementation dependent.~@

The parsing may not work properly."

head)

(skip-until-next-lambda-list-keyword (rest lambda-list))

@@ -112,7 +114,7 @@

(&aux (parse-auxiliary-arguments (rest lambda-list)))

(&rest (parse-rest-arguments (rest lambda-list)))

(otherwise

- (warn "Keyword ~A is implementation dependent.~@

+ (warn "Keyword ~A is implementation dependent.~@

The parsing may not work properly."

head)

(skip-until-next-lambda-list-keyword (rest lambda-list))

@@ -139,7 +141,7 @@

(error 'lambda-list-parsing-error :item head))

(skip-until-next-lambda-list-keyword (rest lambda-list)))

(otherwise

- (warn "Keyword ~A is implementation dependent.~@

+ (warn "Keyword ~A is implementation dependent.~@

The parsing may not work properly."

head)

(skip-until-next-lambda-list-keyword (rest lambda-list))

@@ -165,7 +167,7 @@

(&aux (parse-auxiliary-arguments (rest lambda-list)))

(&rest (error 'lambda-list-parsing-error :item head))

(otherwise

- (warn "Keyword ~A is implementation dependent.~@

+ (warn "Keyword ~A is implementation dependent.~@

The parsing may not work properly."

head)

(skip-until-next-lambda-list-keyword (rest lambda-list))

@@ -187,7 +189,7 @@

(&aux (error 'lambda-list-parsing-error :item head))

(&rest (error 'lambda-list-parsing-error :item head))

(otherwise

- (warn "Keyword ~A is implementation dependent.~@

+ (warn "Keyword ~A is implementation dependent.~@

The parsing may not work properly."

head)

(skip-until-next-lambda-list-keyword (rest lambda-list))

@@ -210,7 +212,7 @@

(&aux (parse-auxiliary-arguments (rest lambda-list)))

(&rest (parse-rest-arguments (rest lambda-list)))

(otherwise

- (warn "Keyword ~A is implementation dependent.~@

+ (warn "Keyword ~A is implementation dependent.~@

The parsing may not work properly."

head)

(skip-until-next-lambda-list-keyword (rest lambda-list))

@@ -277,7 +279,7 @@

(symbol (make-key-lambda-var-info :name var

:type init-value-type

:default-value init-value))

(cons (destructuring-bind (kwd var)

var

(etypecase var

diff -rN -u old-cl-unification-1/lib-dependent/cl-ppcre-template.lisp new-cl-unification-1/lib-dependent/cl-ppcre-template.lisp

--- old-cl-unification-1/lib-dependent/cl-ppcre-template.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/lib-dependent/cl-ppcre-template.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -144,6 +144,6 @@

&optional (env (make-empty-environment))

&key (start 0) end &allow-other-keys)

(unify re-t s env :start start :end end))

;;;; end of file -- cl-ppcre-template.lisp --

diff -rN -u old-cl-unification-1/lib-dependent/named-readtable.lisp new-cl-unification-1/lib-dependent/named-readtable.lisp

--- old-cl-unification-1/lib-dependent/named-readtable.lisp 1970-01-01 00:00:00.000000000 +0000

+++ new-cl-unification-1/lib-dependent/named-readtable.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -0,0 +1,6 @@

+;;;; 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))

diff -rN -u old-cl-unification-1/match-block.lisp new-cl-unification-1/match-block.lisp

--- old-cl-unification-1/match-block.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/match-block.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -3,6 +3,8 @@

;;;; match-block.lisp --

;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.

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

(in-package "UNIFY")

(defun clean-unify-var-name (v)

@@ -10,72 +12,215 @@

(intern (subseq (symbol-name v) 1)

(symbol-package v)))

+(defmacro with-unification-variables ((&rest variables) environment &body body)

+ "Execute body with variables bound to their values in environment."

+ (flet ((variable-bindings (v)

+ `((,v (find-variable-value ',v ,environment))

+ (,(clean-unify-var-name v) ,v))))

+ `(let* ,(mapcan #'variable-bindings variables)

+ (declare (ignorable ,@(mapcar #'clean-unify-var-name variables)))

+ ,@body)))

+(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)))

+ (expand-clause (clause)

+ (destructuring-bind (template object &rest body)

+ (munge-clause 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)))

+ (with-unification-variables ,variables ,match-environment

+ ,@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 #'expand-clause match-clauses)

+ ,@(when errorp `((,errorp ,(or error-form `(error ,match-error)))))

+ ,@(when default-clauses `((t ,@(cdar default-clauses))))

+ ,@(when default `((t ,default))))))))))

+(defmacro %set-documentation ((&rest symbols) docstring)

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

+ (mapcar (lambda (fn) (setf (documentation fn 'function) ,docstring))

+ ',symbols)))

(defmacro match ((template object

&key

- (substitution '(make-empty-environment))

+ (named nil)

+ (match-named nil match-named-p)

+ (substitution nil)

(errorp t)

(error-value nil))

&body forms)

- "Sets up a lexical environment to evaluate FORMS after an unification.

+ (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

+ (named nil)

+ (match-named nil match-named-p)

+ (substitution nil)

+ (errorp t)

+ (error-value nil))

+ &body forms)

+ (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))

+(%set-documentation

+ (match matchf)

+ "Sets up a lexical environment to evaluate FORMS after an unification.

-MATCH unifies a TEMPLATE and an OBJECT and then sets up a lexical

+MATCH and MATCHF unify a TEMPLATE and an OBJECT and then set up a lexical

environment where the variables present in the template are bound

lexically. Note that both variable names '?FOO' and 'FOO' are bound

for convenience.

-The MATCH form returns the values returned by the evaluation of the

+MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will

+generate a template at read-time).

+MATCH and MATCHF forms return the values returned by the evaluation of the

last of the FORMS.

If ERRORP is non-NIL (the default) then the form raises a

UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,

whose default is NIL is returned. (Note that UNIFICATION-FAILUREs

-raising from the evaluation of FORMS will also be caught and handled

+raising from the evaluation of FORMS will /not/ be caught and handled

according to ERRORP settings.)

- (let ((template-vars (collect-template-vars template))

- (env-var (gensym "UNIFICATION-ENV-"))

- (template (if (variablep template)

- `',template ; Logical variables are special-cased.

- template))

- )

- (flet ((generate-var-bindings ()

- (loop for v in template-vars

- nconc (list `(,v (find-variable-value ',v

- ,env-var))

- `(,(clean-unify-var-name v) ,v))))

- )

- `(block nil

- (handler-case

- (let* ((,env-var (unify ,template ,object ,substitution))

- ,@(generate-var-bindings)

- )

- (declare (ignorable ,@(mapcar #'first

- (generate-var-bindings))))

- ,@forms)

- ;; Yes. The above is sligthly wasteful.

- (unification-failure (uf)

- (if ,errorp

- (error uf)

- ,error-value))

- )))))

+A surrounding BLOCK named NAMED is set up around the matching code.")

(define-condition unification-non-exhaustive (unification-failure)

- ())

+ ()

+ (:default-initargs

+ :format-control "Non exhaustive matching."))

-(defmacro matching ((&key errorp

- (default-substitution

- (make-empty-environment)))

- &rest match-clauses)

- "MATCHING sets up a COND-like environment for multiple template matching clauses.

+(defmacro match-cond (&body clauses)

+ (%match-expander 'match 'cond clauses))

+(defmacro matchf-cond (&body clauses)

+ (%match-expander 'matchf 'cond clauses))

-The syntax of MATCHING comprises a number of clauses of the form

+(defmacro matching ((&key errorp

+ default-substitution

+ (named nil)

+ (matching-named nil matching-named-p))

+ &body match-clauses)

+ (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))

+(%set-documentation

+ (match-cond matchf-cond matching)

+ "MATCH-COND, MATCHF-COND, and MATCHING set up a COND-like environment for

+multiple template matching clauses.

+Their syntax comprises a number of clauses of the form

<regular-clause> ::= ((<template> <form>) &body <forms>)

<default-clause> ::= (t &body <forms>)

@@ -83,104 +228,69 @@

<form> and <forms> are regular Common Lisp forms.

<template> is a unification template.

-The full syntax of MATCHING is

- matching (&key errorp default-substitution) <clauses>

+The full syntax is

+ match-cond <clauses>

+ matchf-cond <clauses>

+ matching (&key errorp default-substitution named) <clauses>

Each clause evaluates its forms in an environment where the variables

present in the template are bound lexically. Note that both variable

names '?FOO' and 'FOO' are bound for convenience.

-The values returned by the MATCHING form are those of the last form in

+The values returned by the macros are those of the last form in

the first clause that satisfies the match test.

If ERRORP is non-NIL then if none of the regular clauses matches, then

an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of

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-vars (collect-template-vars template))

- (template (if (variablep template)

- `',template ; Logical variables are

- ; special-cased.

- template))

- )

- (flet ((generate-var-bindings ()

- (loop for v in template-vars

- nconc (list `(,v (find-variable-value

- ',v

- ,clause-var))

- `(,(clean-unify-var-name v) ,v))))

- )

- `((setf ,clause-var

- (ignore-errors (unify ,template

- ,object

- ,substitution)))

- (let* (,@(generate-var-bindings))

- ,@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.

- (match-clauses-env-vars (mapcar (lambda (mc)

- (declare (ignore mc))

- (gensym "UNIFICATION-ENV-")

- )

- match-clauses))

- )

- `(block matching

- (let ,match-clauses-env-vars

- (declare (dynamic-extent ,@match-clauses-env-vars))

- (cond ,@(mapcar (lambda (match-clause match-clause-env-var)

- (build-match-clause match-clause

- match-clause-env-var))

- match-clauses

- match-clauses-env-vars)

- (,errorp

- (error 'unification-non-exhaustive

- :format-control "Non exhaustive matching."))

- ,@(when default-clause (list default-clause))))))

- ))

-;;; match-case --

-;;; Implementation provided by Peter Scott.

-;;;

-;;; Notes:

-;;;

-;;; [MA 20071109]

-;;; When the construction of the inner MATCH clauses could be done

-;;; more intelligently by supplying :ERRORP NIL, thus avoiding the

-;;; HANDLER-CASEs, which are quite expensive. Any takers?

-(defmacro match-case ((object &key errorp default-substitution)

- &rest clauses)

- "MATCH-CASE sets up a CASE-like environment for multiple template matching clauses.

+")

-The syntax of MATCH-CASE comprises a number of clauses of the form

+(defmacro match-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))

+ &body 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 named (match-case-named nil match-case-named-p))

+ &body 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))

+(%set-documentation

+ (match-case match-ecase matchf-case matchf-ecase)

+ "MATCH-CASE, MATCH-ECASE, MATCHF-CASE, and MATCHF-ECASE set up a CASE-like

+environment for multiple template matching clauses.

+Their syntax comprises a number of clauses of the form

<regular-clause> ::= (<template> &body <forms>)

<default-clause> ::= (t &body <forms>)

@@ -188,48 +298,24 @@

<form> and <forms> are regular Common Lisp forms.

<template> is a unification template.

-The full syntax of MATCH-CASE is

- match-case <object> (&key errorp default-substitution) <clauses>

+The full syntax is

+ match-case (<object> &key default-substitution named errorp) <clauses>

+ match-ecase (<object> &key default-substitution named) <clauses>

+ matchf-case (<object> &key default-substitution named errorp) <clauses>

+ matchf-ecase (<object> &key default-substitution named) <clauses>

Each clause evaluates its forms in an environment where the variables

present in the template are bound lexically. Note that both variable

names '?FOO' and 'FOO' are bound for convenience.

-The values returned by the MATCH-CASE form are those of the last form in

+The values returned by the macros are those of the last form in

the first clause that satisfies the match test.

-If ERRORP is non-NIL then if none of the regular clauses matches, then

-an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of

-any default clause. Otherwise, the default clause behaves as a

-standard CASE default clause. The default value of ERRORP is NIL.

- (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 (match (,pattern ,object-var)

- ,@body)

- (unification-failure ()

- ,(generate-matchers (cdr clauses))))))))

- `(let ((,object-var ,object))

- ,(generate-matchers non-otherwise-clauses)))))

+MATCHF-ECASE and MATCHF-CASE behave like MATCH-ECASE and MATCH-CASE, but the

+patterns are not evaluated (i.e., they rely on MATCHF instead of MATCH to

+construct the macro expansion).

+")

;;;;---------------------------------------------------------------------------

;;;; Testing.

diff -rN -u old-cl-unification-1/substitutions.lisp new-cl-unification-1/substitutions.lisp

--- old-cl-unification-1/substitutions.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/substitutions.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -4,6 +4,8 @@

;;;; General CL structures unifier.

;;;; Substitution definitions. Mostly a rehash of the usual SICP stuff.

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

(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.

;;;---------------------------------------------------------------------------

@@ -39,6 +41,11 @@

(setf (cdr b) v))

+(defun bindings-values (bindings) (mapcar #'cdr bindings))

+(defun bindings-keys (bindings) (mapcar #'car bindings))

(define-condition unification-variable-unbound (unbound-variable)

()

@@ -51,7 +58,7 @@

;;;---------------------------------------------------------------------------

;;; Frames.

-(defstruct frame

+(defstruct (frame (:constructor make-frame (&optional bindings)))

(bindings () :type bindings))

(defun empty-frame-p (f)

@@ -72,6 +79,13 @@

(values (cdr b) t)

(values nil nil))))

+(defun frame-variables (frame)

+ (mapcar 'binding-variable (frame-bindings frame)))

+(defun frame-values (frame)

+ (mapcar 'binding-value (frame-bindings frame)))

;;;---------------------------------------------------------------------------

;;; Environments.

@@ -101,15 +115,33 @@

(make-environment :frames (list (make-frame))))

(defun copy-environment (env)

+ (declare (type environment env))

(make-environment :frames (copy-list (environment-frames 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)))

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

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

-(defun empty-environment-p (env &aux (env-frames (environment-frames env)))

+(defun empty-environment-p (env)

(declare (type environment env))

- (and (= 1 (list-length env-frames))

- (empty-frame-p (first env-frames))))

+ (let ((env-frames (environment-frames env)))

+ (declare (type list env-frames))

+ (and (= 1 (list-length env-frames))

+ (empty-frame-p (first env-frames)))))

(defparameter *null-environment* (make-empty-environment))

@@ -131,19 +163,64 @@

-(defun extend-environment (var pat env)

+(defun extend-environment (var pat &optional (env (make-empty-environment)))

(let ((first-frame (first-frame env)))

(setf (frame-bindings first-frame)

(extend-bindings var pat (frame-bindings first-frame)))

env))

+(defun fill-environment (vars pats &optional (env (make-empty-environment)))

+ (map nil (lambda (v p) (extend-environment v p env)) vars pats)

+ env)

+(defun fill-environment* (vars-pats &optional (env (make-empty-environment)))

+ (loop for (v . p) in vars-pats do (extend-environment v p env))

+ env)

+(declaim (inline v?))

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

+ (values t boolean))

+ find-variable-value)

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

+ (values t boolean))

+ v?))

(defun v? (s env &optional (plain-symbol-p nil))

(find-variable-value (if plain-symbol-p

(make-var-name s)

env))

+(defun environment-variables (env)

+ (mapcan #'frame-variables (environment-frames env)))

+(defun environment-values (env)

+ (mapcan #'frame-values (environment-frames env)))

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

+;;; Simple debugging.

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

+ (declare (type frame f))

+ (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))

+ (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)

+ )))

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

diff -rN -u old-cl-unification-1/template-reader.lisp new-cl-unification-1/template-reader.lisp

--- old-cl-unification-1/template-reader.lisp 1970-01-01 00:00:00.000000000 +0000

+++ new-cl-unification-1/template-reader.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -0,0 +1,67 @@

+;;; 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|)))

diff -rN -u old-cl-unification-1/templates-hierarchy-saved.lisp new-cl-unification-1/templates-hierarchy-saved.lisp

--- old-cl-unification-1/templates-hierarchy-saved.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/templates-hierarchy-saved.lisp 1970-01-01 00:00:00.000000000 +0000

@@ -1,458 +0,0 @@

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

-(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.

-;;; Templates.

-;;; Essentially we extend the type specifier language.

-;;; The interesting thing is that we need to specify how a "match"

-;;; between a template and a CL object is performed.

-;;; A template is one of the following

-;;;

-;;; <template> ::= <logical variable>

-;;; | <structure template>

-;;; | <instance template>

-;;; | <destructuring template>

-;;; | <vector template>

-;;; | <sequence template>

-;;; | <array template>

-;;; | <type template>

-;;; | <lisp object>

-;;;

-;;; Destructuring Template Lambda List (as per standard CL terminology)

-;;;

-;;; <destructuring template lambda list> ::= <a "destructuring LL" with <template> in lieu of <var>>

-;;; Templates for Structures and Instances

-;;;

-;;; <structure template> ::= (<class designator> <structure-slot-spec>*)

-;;;

-;;; <instance template> ::= (<class designator> <slot-spec>*)

-;;;

-;;; where

-;;;

-;;; <structure-slot-spec> ::= (<reader-name> <template>)

-;;; <instance-slot-spec> ::= (slot-access <accessor-name> <template>)

-;;; | (slot-value <slot-name> <template>)

-;;; Template for Sequences

-;;;

-;;; <sequence template> ::= (<container type> . <destructuring template lambda list>)

-;;; | (subseq <from> <to> . <destructuring template lambda list>)

-;;; <container type> ::= list | cons | vector | array

-;;; Templates for Vectors and Arrays.

-;;;

-;;; <vector template> ::= (vector . <destructuring template lambda list>)

-;;;

-;;; <array template> ::= (array <shape template>)

-;;; | (aref <index template> <template>)

-;;; <shape template> ::= (<destructuring template lambda list>)

-;;; | <sequence template>

-;;; | (<shape template>)

-;;; Templates for LIST and CONS

-;;; <list template> ::= (list <destructuring template lambda list>)

-;;; <cons template> ::= (cons <template> <template>)

-;;; A regular list or cons acts as a list or cons template.

-(define-condition unification-template-error (simple-error)

- ())

-;;; Templates are introduced by the reader macro #T(...)

-(defclass template ()

- ((spec :accessor template-spec :type (or symbol cons) :initarg :spec))

- (:default-initargs :spec nil))

-(defgeneric template-p (x)

- (:method ((x template)) t)

- (:method ((x t)) nil))

-(defclass type-template (template) ())

-(defgeneric type-template-p (x)

- (:method ((x type-template)) t)

- (:method ((x t)) nil))

-(defgeneric type-template-type-spec (x)

- (:method ((x type-template))

- (let ((spec (template-spec x)))

- (if spec

- (first spec)

- 'null))))

-(defclass nil-template (type-template) ()) ; This is the point where we break the type hierarchy.

-(defgeneric nil-template-p (x)

- (:method ((x nil-template)) t)

- (:method ((x t)) nil))

-(defclass expression-template (template) ())

-(defgeneric expression-template-p (x)

- (:method ((x expression-template)) t)

- (:method ((x t)) nil))

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

- (format stream "#T~S" (template-spec template)))

-(defclass sequence-template (type-template) ())

-(defgeneric sequence-template-p (x)

- (:method ((x sequence-template)) t)

- (:method ((x t)) nil))

-(defclass list-template (sequence-template) ())

-(defgeneric list-template-p (x)

- (:method ((x list-template)) t)

- (:method ((x t)) nil))

-(defclass array-template (type-template) ())

-(defgeneric array-template-p (x)

- (:method ((x array-template)) t)

- (:method ((x t)) nil))

-(defclass vector-template (sequence-template array-template) ())

-(defgeneric vector-template-p (x)

- (:method ((x vector-template)) t)

- (:method ((x t)) nil))

-(defclass string-template (vector-template) ())

-(defgeneric string-template-p (x)

- (:method ((x string-template)) t)

- (:method ((x t)) nil))

-(defclass symbol-template (type-template) ())

-(defgeneric symbol-template-p (x)

- (:method ((x symbol-template)) t)

- (:method ((x t)) nil))

-(defclass number-template (type-template) ())

-(defgeneric number-template-p (x)

- (:method ((x number-template)) t)

- (:method ((x t)) nil))

-(defclass structure-object-template (type-template) ())

-(defgeneric structure-object-template-p (x)

- (:method ((x structure-object-template)) t)

- (:method ((x t)) nil))

-(defclass standard-object-template (type-template) ())

-(defgeneric standard-object-template-p (x)

- (:method ((x standard-object-template)) t)

- (:method ((x t)) nil))

-;;; Expression Templates.

-(defclass subseq-template (expression-template) ())

-(defgeneric subseq-template-p (x)

- (:method ((x subseq-template)) t)

- (:method ((x t)) nil))

-(defclass elt-template (expression-template) ())

-(defgeneric elt-template-p (x)

- (:method ((x elt-template)) t)

- (:method ((x t)) nil))

-(defclass aref-template (elt-template) ())

-(defgeneric aref-template-p (x)

- (:method ((x aref-template)) t)

- (:method ((x t)) nil))

-(defclass nth-template (elt-template) ())

-(defgeneric nth-template-p (x)

- (:method ((x nth-template)) t)

- (:method ((x t)) nil))

-(defclass nthcdr-template (elt-template) ())

-(defgeneric nthcdr-template-p (x)

- (:method ((x nthcdr-template)) t)

- (:method ((x t)) nil))

-(defgeneric make-template (kind spec))

-;;; Setting up the reader macro.

-(defun |#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 #'|#T-reader|))

-(defmethod make-template ((kind null) (spec symbol))

- (assert (null spec) (spec) "MAKE-TEMPLATE called erroneously with ~S and ~S." kind spec)

- (make-instance 'nil-template :spec spec))

-(defmethod make-template ((kind symbol) (spec symbol))

- (make-instance 'symbol-template :spec spec))

-(defmethod make-template ((kind (eql 'symbol)) (spec cons))

- (make-instance 'symbol-template :spec spec))

-(defmethod make-template ((kind symbol) (spec cons))

- (cond ((subtypep kind 'number)

- (make-instance 'number-template :spec spec))

- ((subtypep kind 'structure-object)

- (make-instance 'structure-object-template :spec spec))

- ((subtypep kind 'standard-object)

- (make-instance 'standard-object-template :spec spec))

- (t

- (error 'unification-template-error

- :format-control "Unknown template specifier ~S."

- :format-arguments (list kind)))

- ))

-(defmethod make-template ((kind cons) (spec cons))

- (cond ((subtypep kind 'number)

- (make-instance 'number-template :spec spec))

- ((subtypep kind 'string)

- (make-instance 'string-template :spec spec))

- ((subtypep kind 'vector)

- (make-instance 'vector-template :spec spec))

- ((subtypep kind 'array)

- (make-instance 'array-template :spec spec))

- (t

- (error 'unification-template-error

- :format-control "Unknown template specifier ~S."

- :format-arguments (list kind)))

- ))

-(defmethod make-template ((kind (eql 'sequence)) (spec cons))

- (make-instance 'sequence-template :spec spec))

-(defmethod make-template ((kind (eql 'list)) (spec cons))

- (make-instance 'list-template :spec spec))

-(defmethod make-template ((kind (eql 'vector)) (spec cons))

- (make-instance 'vector-template :spec spec))

-(defmethod make-template ((kind (eql 'string)) (spec cons))

- (make-instance 'stringvector-template :spec spec))

-(defmethod make-template ((kind (eql 'array)) (spec cons))

- (make-instance 'array-template :spec spec))

-(defmethod make-template ((kind (eql 'subseq)) (spec cons))

- (make-instance 'subseq-template :spec spec))

-(defmethod make-template ((kind (eql 'elt)) (spec cons))

- (make-instance 'elt-template :spec spec))

-(defmethod make-template ((kind (eql 'aref)) (spec cons))

- (make-instance 'aref-template :spec spec))

-(defmethod make-template ((kind (eql 'nth)) (spec cons))

- (make-instance 'nth-template :spec spec))

-(defmethod make-template ((kind (eql 'nthcdr)) (spec cons))

- (make-instance 'nthcdr-template :spec spec))

-;;; Implementation.

-;;; Symbol Templates.

-;;; Specification is

-;;;

-;;; (symbol <symbol>)

-(defun symbol-template-symbol (x)

- (declare (type symbol-template x))

- (assert (symbol-template-p x) (x) "Non symbol template ~S." x)

- (let ((spec (template-spec x)))

- (cond ((symbolp spec) spec)

- ((consp spec) (second spec)))))

-;;; Number template

-;;; Specification is

-;;;

-;;; (<number type> <number>)

-;;; or

-;;;

-;;; <number>

-(defun number-template-number (x)

- (declare (type number-template x))

- (assert (number-template-p x) (x) "Non number template ~S." x)

- (let ((spec (template-spec x)))

- (etypecase spec

- (symbol spec)

- (number spec)

- (consp (second spec)))))

-;;; Sequence Templates.

-;;; Specification is

-;;;

-;;; (<sequence subtype> . <destructuring template lambda list>)

-;;; or

-;;; (subseq <from> <to> . <destructuring template lambda list>)

-(defun sequence-template-lambda-list (x)

- (declare (type sequence-template x))

- (assert (sequence-template-p x) (x) "Non sequence template ~S." x)

- (rest (template-spec x)))

-;;; Array Templates.

-;;; Specification is

-;;;

-;;; (array (['*' | <element type>] [<dimension spec>]) <shape template>)

-;;; or

-;;; (<array type specifier> <shape template>)

-(defun array-template-shape-template (x)

- (declare (type array-template x))

- (assert (array-template-p x) (x) "Non array template ~S." x)

- (let ((spec (template-spec x)))

- (third spec)))

-(defun array-template-type-template (x)

- (declare (type array-template x))

- (assert (array-template-p x) (x) "Non array template ~S." x)

- (let ((spec (template-spec x)))

- (second spec)))

-(defun aref-template-indexes (x)

- (declare (type aref-template x))

- (assert (aref-template-p x) (x) "Non aref template ~S." x)

- (let ((spec (template-spec x)))

- (second spec)))

-(defun aref-template-element (x)

- (declare (type aref-template x))

- (assert (aref-template-p x) (x) "Non array template ~S." x)

- (let ((spec (template-spec x)))

- (third spec)))

-;;; Vector Templates.

-;;; Specification is

-;;;

-;;; (vector . <destructuring template lambda list>)

-;;; Structure and Standard Object Templates.

-(defun structure-object-template-slots (x)

- (and (structure-object-template-p x)

- (rest (template-spec x))))

-(defun standard-object-template-slots (x)

- (and (standard-object-template-p x)

- (rest (template-spec x))))

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

-;;; Template variables.

-;;; Let's walk down a template.

-;;; Note that there is an asymmetry here: I admit some containers to have

-;;; variables inside, but I do not search instances of a class for variables.

-;;; This is an asymmetry that would be way too hard to fix without more

-;;; introspective power (which is available in the MOP, but not standard.)

-(defgeneric collect-template-vars (template))

-(defmethod collect-template-vars ((template template))

- (let ((spec (template-spec template)))

- (nconc (collect-template-vars (car spec))

- (collect-template-vars (cdr spec)))))

-(defmethod collect-template-vars ((template symbol-template))

- (let ((template (symbol-template-symbol template)))

- (when (and (variablep template) (not (variable-any-p template)))

- (list template))))

-(defmethod collect-template-vars ((template number-template))

- (let ((template (number-template-number template)))

- (etypecase template

- (number ())

- (symbol (cond ((variablep template) template)

- ((and (boundp template)

- (numberp (symbol-value template)))

- (symbol-value template))

- (t

- (error "Invalid number template ~S." template)))))))

-(defmethod collect-template-vars ((template symbol))

- (when (and (variablep template) (not (variable-any-p template)))

- (list template)))

-(defmethod collect-template-vars ((template null))

- ())

-(defmethod collect-template-vars ((template cons))

- (nconc (collect-template-vars (car template))

- (collect-template-vars (cdr template))))

-(defmethod collect-template-vars ((template string))

- ())

-(defmethod collect-template-vars ((template vector))

- (loop for e across template

- nconc (collect-template-vars e)))

-(defmethod collect-template-vars ((template array))

- (loop for i below (array-total-size template)

- nconc (collect-template-vars (row-major-aref template i))))

-(defmethod collect-template-vars ((template t))

- ())

-;;; end of file -- templates.lisp --

diff -rN -u old-cl-unification-1/templates-hierarchy.lisp new-cl-unification-1/templates-hierarchy.lisp

--- old-cl-unification-1/templates-hierarchy.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/templates-hierarchy.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -1,4 +1,8 @@

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

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

+;;;; templates-hierarchy.lisp --

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

(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.

@@ -104,7 +108,7 @@

(:method ((x t)) nil))

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

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

(format stream "#T~S" (template-spec template)))

@@ -121,6 +125,15 @@

(:method ((x list-template)) t)

(:method ((x t)) nil))

+(defclass lambda-template (list-template expression-template) ())

+(defgeneric lambda-template-p (x)

+ (:method ((x lambda-template)) t)

+ (:method ((x t)) nil))

(defclass array-template (type-template) ())

(defgeneric array-template-p (x)

@@ -220,70 +233,6 @@

(defgeneric make-template (kind spec))

-;;; 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)))

-||#

(defmethod make-template ((kind null) (spec symbol))

(assert (null spec) (spec) "MAKE-TEMPLATE called erroneously with ~S and ~S." kind spec)

(make-instance 'nil-template :spec spec))

@@ -332,6 +281,9 @@

(defmethod make-template ((kind (eql 'list)) (spec cons))

(make-instance 'list-template :spec spec))

+(defmethod make-template ((kind (eql 'lambda)) (spec cons))

+ (make-instance 'lambda-template :spec spec))

(defmethod make-template ((kind (eql 'vector)) (spec cons))

(make-instance 'vector-template :spec spec))

@@ -393,6 +345,23 @@

(cons (second spec)))))

+(defun number-template-numeric-type (x)

+ (declare (type number-template x))

+ (let ((n (number-template-number x)))

+ (if (numberp n)

+ (type-of n)

+ (first (template-spec x)))))

+(defun number-template-numeric-class (x)

+ (declare (type number-template x))

+ (let ((n (number-template-number x)))

+ (if (numberp n)

+ (class-of n)

+ (find-class (first (template-spec x))))))

;;; Sequence Templates.

;;; Specification is

;;;

@@ -479,11 +448,19 @@

;;; Structure and Standard Object Templates.

+(defun structure-object-template-class (x)

+ (and (structure-object-template-p x)

+ (first (template-spec x))))

(defun structure-object-template-slots (x)

(and (structure-object-template-p x)

(rest (template-spec x))))

+(defun standard-object-template-class (x)

+ (and (standard-object-template-p x)

+ (first (template-spec x))))

(defun standard-object-template-slots (x)

(and (standard-object-template-p x)

(rest (template-spec x))))

diff -rN -u old-cl-unification-1/test/unification-tests.lisp new-cl-unification-1/test/unification-tests.lisp

--- old-cl-unification-1/test/unification-tests.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/test/unification-tests.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -1,10 +1,17 @@

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

;;;; unification-tests.lisp --

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

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

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

-(use-package "UNIFY")

-(use-package "UTIL.TEST")

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

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

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

+(in-package "UNIFY.TESTS")

+;; nil seems like a lousy default for this

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

(with-tests (:name "basic constant unification")

(test t (unify:environment-p (unify 42 42)))

@@ -36,7 +43,7 @@

(test-error (unify "I am a string" "I am A string")

:condition-type 'unification-failure)

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

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

(unify:environment-p (unify "I am a string" "I am A string"))))

)

@@ -95,6 +102,8 @@

(test t (unify:environment-p (unify #C(0 1) #T(complex #C(0 1)))))

(test '(42 T) (v? '?x (unify #T(number ?x) 42)) :multiple-values t)

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

+ :multiple-values t)

(test-error (unify 42 #T(float 42.0))

:condition-type 'unification-failure

@@ -104,32 +113,97 @@

)

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

(defclass test1 ()

((a :initarg :a :accessor a)

(b :initarg :b :accessor b)))

+(defstruct s-root a)

+(defstruct (s-child (:include s-root)) b)

(with-tests (:name "advanced templates unification")

(test '(a T) (v? '?x (unify #2A((1 #T(symbol ?x) 3) (_ _ _))

#2A((1 a 3) (q w e))))

:multiple-values t)

- (test '(#\f T) (ignore-errors (v? '?x (unify "asdfasdfasdf" #T(elt 3 ?x))))

- :multiple-values t

- :known-failure t

- :fail-info "ELT templates must be fixed.")

- (test '(42 T) (ignore-errors (v? 'x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))

- :multiple-values t

- :known-failure t

- :fail-info "NTH templates must be fixed.")

+ (test '(#\Space T) (ignore-errors (v? '?x (unify "This is a string!" #T(elt 4 ?x))))

+ :multiple-values t)

+ (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))

+ :multiple-values t)

+ (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(elt 2 ?x))))

+ :multiple-values t)

+ (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(aref 2 ?x))))

+ :multiple-values t)

+ (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(elt 2 ?x))))

+ :multiple-values t)

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

+ :multiple-values t)

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

+ :multiple-values t)

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

+ :multiple-values t)

+ (test-error (unify #(0 1 42 3 4 5) #T(nth 2 ?x))

+ :condition-type 'unification-failure

+ :announce t)

+ (test '(foo (1) (2) (3)) (let ((result-env (unify '(0 1 #T(list foo _ &rest ?z) 42)

+ '(0 1 (?y bar (1) (2) (3)) 42)))

+ )

+ (cons (v? '?y result-env)

+ (v? '?z result-env)))

+ :test #'equal)

(test '(2 T) (v? '?x (unify #T(test1 a #T(list 1 ?x 3 &rest) b "woot")

- (make-instance 'test1 :a '(1 2 3) :b "woot")))

+ (make-instance 'test1 :a '(1 2 3) :b "woot")))

+ :multiple-values t)

+ (test-error (unify #T(s-root s-root-a '(1 ?x 3 4))

+ (make-s-root :a '(1 2 3 4)))

+ :condition-type 'unification-failure

+ :announce t

+ ;; #T reader non evaluating sub forms.

+ )

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 4))

+ (make-s-root :a '(1 2 3 4))))

+ :multiple-values t)

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a (1 ?x 3 4))

+ (make-s-root :a '(1 2 3 4))))

+ :multiple-values t)

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 &rest))

+ (make-s-root :a '(1 2 3 4))))

+ :multiple-values t)

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a #(1 ?x 3 4))

+ (make-s-root :a #(1 2 3 4))))

+ :multiple-values t)

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(vector 1 ?x 3 &rest))

+ (make-s-root :a #(1 2 3 4))))

:multiple-values t)

)

+(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."))

(defun nested-match-cases (input)

(match-case (input)

@@ -138,12 +212,85 @@

collect (match-case (b)

('(:c ?c) ?c)

('(:d ?d) ?d)

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

- (otherwise "error-outer")))

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

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

-(with-tests (:name "control flow")

- (test "error-outer" (nested-match-cases '(:a 42 :b 33)) :test 'string=)

+(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))))

+(with-tests (:name "control flow")

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

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

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

+ :test #'equal)

+ (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) '(x) :errorp nil)

+ (error 'inner-unification-failure))

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

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

+ (error 'inner-unification-failure))

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

+ (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-unification-failure))

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

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

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

+ ('(y) :fail)

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

+ ('(?x) x))

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

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

+ ((y) :fail)

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

+ ((?x) x))

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

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

+ ('(a) :fail)

+ ('(b) :fail)

+ ('(?x) x)))

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

+ ((a) :fail)

+ ((b) :fail)

+ ((?x) x)))

)

diff -rN -u old-cl-unification-1/unification-package.lisp new-cl-unification-1/unification-package.lisp

--- old-cl-unification-1/unification-package.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/unification-package.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -1,24 +1,24 @@

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

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

-(defpackage "CL.EXT.DACF.UNIFICATION" (:use "CL")

- (:nicknames "UNIFY")

+;;;; unification-package.lisp --

+;;;; Package definition for the CL-UNIFICATION library.

+;;;;

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

+(defpackage "IT.UNIMIB.DISCO.MA.CL.EXT.DACF.UNIFICATION" (:use "CL")

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

(:documentation "The CL.EXT.DACF.UNIFICATION Package.

This package contains all the definitions necessary for the general

Common Lisp unifier to work.

The package also has the \"UNIFY\" nickname.")

(:export

- "MAKE-TEMPLATE"

- "TEMPLATEP"

- "TEMPLATE-SPEC")

- (:export

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

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

"UNIFY"

- "FIND-VARIABLE-VALUE"

- "V?"

- "MAKE-EMPTY-ENVIRONMENT"

"APPLY-SUBSTITUTION"

"UNIFICATION-FAILURE"

@@ -27,11 +27,64 @@

(:export

"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

"MATCH"

+ "MATCHF"

+ "MATCH-COND"

+ "MATCHF-COND"

"MATCHING"

- "MATCH-CASE"))

+ "MATCH-CASE"

+ "MATCH-ECASE"

+ "MATCHF-CASE"

+ "MATCHF-ECASE"

+ )

+ (:export

+ "UNIFY*"

+ "UNIFY-EQUATIONS"

+ "UNIFY-EQUATIONS*")

+ (:export

+ "ENABLE-TEMPLATE-READER"

+ "MAKE-TEMPLATE"

+ "TEMPLATEP"

+ "TEMPLATE-SPEC"

+ "COLLECT-TEMPLATE-VARS"

+ )

+ #+cl-ppcre

+ (:export

+ "REGULAR-EXPRESSION"

+ "REGEXP")

+ #+named-readtables

+ (:export

+ "TEMPLATE-READTABLE")

+ )

-;;; end of file -- unification-package.lisp --

+;;;; end of file -- unification-package.lisp --

diff -rN -u old-cl-unification-1/unification.asd new-cl-unification-1/unification.asd

--- old-cl-unification-1/unification.asd 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/unification.asd 1970-01-01 00:00:00.000000000 +0000

@@ -1,22 +0,0 @@

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

-;;; unification.asd --

-;;; ASDF system file.

-;;;

-;;; Note:

-;;; [20071109 MA]

-;;; This file is OBSOLETE. Use 'cl-unification.asd' instead.

-(asdf:defsystem cl-unification

- :author "Marco Antoniotti"

- :serial t

- :components ((:file "unification-package")

- (:file "variables")

- (:file "substitutions")

- (:file "lambda-list-parsing")

- (:file "templates-hierarchy")

- (:file "unifier")

- (:file "match-block")

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

-;;; end of file -- unification.asd --

diff -rN -u old-cl-unification-1/unification.system new-cl-unification-1/unification.system

--- old-cl-unification-1/unification.system 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/unification.system 1970-01-01 00:00:00.000000000 +0000

@@ -1,20 +0,0 @@

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

-;;; unification.system --

-;;; MK:DEFSYSTEM system file.

-;;;

-;;; Note:

-;;; [20071109 MA]

-;;; This file is OBSOLETE. Use 'cl-unification.system' instead.

-(mk:defsystem "UNIFICATION"

- :components ("unification-package"

- "variables"

- "substitutions"

- "lambda-list-parsing"

- "templates-hierarchy"

- "unifier"

- "match-block"

- "apply-substitution"))

-;;; end of file -- unification.system --

diff -rN -u old-cl-unification-1/unifier.lisp new-cl-unification-1/unifier.lisp

--- old-cl-unification-1/unifier.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/unifier.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -3,9 +3,11 @@

;;; unifier.lisp

;;; General CL structures unifier.

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

(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.

-(defgeneric unify (a b &optional env)

+(defgeneric unify (a b &optional env &key &allow-other-keys)

(:documentation

"Unifies two objects A and B given a substitution ENV.

A is a Common Lisp object and B is either a Common Lisp object or a

@@ -22,7 +24,9 @@

;;;===========================================================================

;;; Simple, non template methods.

-(defmethod unify ((a symbol) (b list) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b list)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

"Unifies a symbol A and a list B in an environment ENV.

If A is not a variable then an error of type UNIFICATION-FAILURE is

signaled. If A is a unification variable, then the environment ENV is

@@ -35,7 +39,9 @@

:format-arguments (list a b)))))

-(defmethod unify ((b list) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b list) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

"Unifies a symbol B and a list A in an environment ENV.

If A is not a variable then an error of type UNIFICATION-FAILURE is

signaled. If A is a unification variable, then the environment ENV is

@@ -48,7 +54,9 @@

:format-arguments (list b a)))))

-(defmethod unify ((a list) (b list) &optional (env (make-empty-environment)))

+(defmethod unify ((a list) (b list)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

"Unifies a list A and a list B in an environment ENV.

The unification procedure proceedes recursively on each element of

both lists. If two elements cannot be unified then an error of type

@@ -58,7 +66,9 @@

-(defmethod unify ((a number) (b number) &optional (env (make-empty-environment)))

+(defmethod unify ((a number) (b number)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

"Unifies two numbers A and B.

Two numbers unify only if and only if they are equal as per the function #'=, in

which case an unmodified envirironment ENV is returned.

@@ -72,27 +82,55 @@

:format-arguments (list a b))))

-(defparameter *unify-string-case-insensitive-p* nil)

+(defparameter *unify-string-case-sensitive-p* t)

+(defmethod unify ((a character) (b character)

+ &optional (env (make-empty-environment))

+ &key

+ (case-sensitive *unify-string-case-sensitive-p*)

+ &allow-other-keys)

+ "Unifies two strings A and B.

+Two CHARACTERs A and B unify if and only if they satisfy either #'CHAR= or

+#'CHAR-EQUAL. The choice of which of test to perform (#'CHAR= or #'CHAR-EQUAL)

+is made according to the value of the variable

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

+If A and B unify then an unmodified environment ENV is returned,

+otherwise an error of type UNIFICATION-FAILURE is signaled."

+ (cond ((and case-sensitive (char= a b))

+ env)

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

+ env)

+ (t

+ (error 'unification-failure

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

+ :format-arguments (list a b)))))

-(defmethod unify ((a string) (b string) &optional (env (make-empty-environment)))

+(defmethod unify ((a string) (b string)

+ &optional (env (make-empty-environment))

+ &key

+ (case-sensitive *unify-string-case-sensitive-p*)

+ &allow-other-keys)

"Unifies two strings A and B.

Two strings A and B unify if and only if they satisfy either #'STRING= or

#'STRING-EQUAL. The choice of which of test to perform (#'STRING= or #'STRING-EQUAL)

is made according to the value of the variable

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

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

If A and B unify then an unmodified environment ENV is returned,

otherwise an error of type UNIFICATION-FAILURE is signaled."

- (cond ((and *unify-string-case-insensitive-p* (string-equal a b))

+ (cond ((and case-sensitive (string= a b))

env)

- ((string= a b)

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

env)

(error 'unification-failure

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

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

:format-arguments (list a b)))))

-(defmethod unify ((a symbol) (b string) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b string)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(cond ((variable-any-p a) env)

((variablep a) (var-unify a b env))

(t (error 'unification-failure

@@ -100,7 +138,9 @@

:format-arguments (list a b)))))

-(defmethod unify ((b string) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b string) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(cond ((variable-any-p a) env)

((variablep a) (var-unify a b env))

(t (error 'unification-failure

@@ -108,7 +148,9 @@

:format-arguments (list b a)))))

-(defmethod unify ((a symbol) (b symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(cond ((variable-any-p a) env)

((variablep a) (var-unify a b env))

((variable-any-p b) env)

@@ -119,27 +161,36 @@

:format-arguments (list a b)))))

-(defmethod unify ((a symbol) (b t) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b t)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(cond ((variable-any-p a) env)

((variablep a) (var-unify a b env))

(t (call-next-method))))

-(defmethod unify ((b t) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b t) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(cond ((variable-any-p a) env)

((variablep a) (var-unify a b env))

(t (call-next-method))))

-(defmethod unify ((a symbol) (b array) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b array)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(cond ((variable-any-p a) env)

((variablep a) (var-unify a b env))

(t (error 'unification-failure

- :format-control "Cannot unify a symbol with an array or vector: ~S and ~S."

+ :format-control "Cannot unify a symbol with ~

+ an array or vector: ~S and ~S."

:format-arguments (list a b)))))

-(defmethod unify ((b array) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b array) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(cond ((variable-any-p a) env)

((variablep a) (var-unify a b env))

(t (error 'unification-failure

@@ -147,7 +198,9 @@

:format-arguments (list a b)))))

-(defmethod unify ((as vector) (bs vector) &optional (env (make-empty-environment)))

+(defmethod unify ((as vector) (bs vector)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unless (= (length as) (length bs))

(error 'unification-failure

:format-control "Cannot unify two vectors of different length: ~D and ~D."

@@ -158,7 +211,9 @@

finally (return mgu)))

-(defmethod unify ((s1 sequence) (s2 sequence) &optional (env (make-empty-environment)))

+(defmethod unify ((s1 sequence) (s2 sequence)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unless (= (length s1) (length s2))

(error 'unification-failure

:format-control "Cannot unify two sequences of different length: ~D and ~D."

@@ -172,21 +227,25 @@

(defgeneric untyped-unify (a b &optional env))

-(defmethod untyped-unify ((as list) (bs vector) &optional (env (make-empty-environment)))

+(defmethod untyped-unify ((as list) (bs vector)

+ &optional (env (make-empty-environment)))

(loop for a in as

for b across bs

for mgu = (unify a b env) then (unify a b mgu)

finally (return mgu)))

-(defmethod untyped-unify ((as vector) (bs list) &optional (env (make-empty-environment)))

+(defmethod untyped-unify ((as vector) (bs list)

+ &optional (env (make-empty-environment)))

(untyped-unify bs as env))

(defmethod untyped-unify ((a t) (b t) &optional (env (make-empty-environment)))

(unify a b env))

-(defmethod unify ((as array) (bs array) &optional (env (make-empty-environment)))

+(defmethod unify ((as array) (bs array)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unless (= (array-total-size as) (array-total-size bs))

(error 'unification-failure

:format-control "Cannot unify two arrays of different total size: ~D and ~D."

@@ -200,7 +259,9 @@

;;; Catch all method.

-(defmethod unify ((a t) (b t) &optional (env (make-empty-environment)))

+(defmethod unify ((a t) (b t)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(if (equalp a b)

env

(error 'unification-failure

@@ -229,10 +290,13 @@

;;; Special catch all method.

-(defmethod unify ((x template) (y template) &optional (env (make-empty-environment)))

+(defmethod unify ((x template) (y template)

+ &optional (env)

+ &key &allow-other-keys)

(declare (ignore env))

(error 'unification-failure

- :format-control "Unification of two templates of type ~A and ~A has not been yet implemented."

+ :format-control "Unification of two templates of type ~A and ~A ~

+ has not been yet implemented."

:format-arguments (list (class-name (class-of x))

(class-name (class-of y)))))

@@ -241,45 +305,58 @@

;;; NIL special unification methods.

(defmethod unify ((x null) (y null)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

env)

(defmethod unify ((x null) (nt nil-template)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

env)

(defmethod unify ((nt nil-template) (x null)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

env)

(defmethod unify ((nt1 nil-template) (nt2 nil-template)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

env)

;;;---------------------------------------------------------------------------

;;; Symbol methods.

-(defmethod unify ((a symbol) (b symbol-template) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b symbol-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(cond ((variable-any-p a) env)

((variablep a) (var-unify a b env))

(t (unify a (symbol-template-symbol b) env))))

-(defmethod unify ((b symbol-template) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b symbol-template) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

-(defmethod unify ((a symbol) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b template)

+ &optional (env)

+ &key &allow-other-keys)

(declare (ignore env))

(error 'unification-failure

:format-control "Cannot unify symbol ~S with template ~S."

:format-arguments (list a b)))

-(defmethod unify ((b template) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

@@ -287,47 +364,74 @@

;;;---------------------------------------------------------------------------

;;; Number template methods.

-(defmethod unify ((a number) (b number-template) &optional (env (make-empty-environment)))

+(defmethod unify ((a number) (b number-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a (number-template-number b) env))

-(defmethod unify ((b number-template) (a number) &optional (env (make-empty-environment)))

+(defmethod unify ((b number-template) (a number)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

-(defmethod unify ((a number) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a number) (b template)

+ &optional (env)

+ &key &allow-other-keys)

(declare (ignore env))

(error 'unification-failure

:format-control "Cannot unify the number ~S with template ~S."

:format-arguments (list a b)))

-(defmethod unify ((b template) (a number) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a number)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

;;;---------------------------------------------------------------------------

;;; Sequence (List) template methods

-(defmethod unify ((a sequence) (b template) &optional (env (make-empty-environment)))

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

+ &optional (env)

+ &key &allow-other-keys)

(declare (ignore env))

(error 'unification-failure

- :format-control "Cannot unify a sequence with a non sequence or non sequence access template: ~S ~S."

+ :format-control "Cannot unify a sequence with a non sequence ~

+ or non sequence access template: ~S and ~S."

:format-arguments (list a b)))

-(defmethod unify ((b template) (a sequence) &optional (env (make-empty-environment)))

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

+#| Needs to be fixed.

+(defmethod unify ((a list) (b lambda-template) &optional (env (make-empty-environment)))

+ (unify a (template-spec b) env))

+(defmethod unify ((b lambda-template) (a list) &optional (env (make-empty-environment)))

+ (unify (template-spec b) a env))

+|#

;;; The next is incomplete and does not signal appropriate errors.

-(defmethod unify ((a list) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a list) (b template)

+ &optional (env)

+ &key &allow-other-keys)

(declare (ignore env))

(error 'unification-failure

:format-control "Cannot unify a list with a non-list template: ~S ~S."

:format-arguments (list a b)))

-(defmethod unify ((a list) (b sequence-template) &optional (env (make-empty-environment)))

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(let ((template-lambda-list (sequence-template-lambda-list b))

(ll (list-length a))

)

@@ -338,7 +442,7 @@

:key-variable-test #'valid-template-p

:rest-variable-test #'valid-template-p

)

(let* ((n-vars (list-length vars))

(n-optionals (list-length optionals))

(env (unify (subseq a 0 (min ll (list-length vars)))

@@ -349,13 +453,15 @@

(setf env (unify (subseq a n-vars (+ n-vars n-optionals)) optionals env)))

(when (and rest (>= ll (+ n-vars n-optionals)))

(setf env (unify (subseq a (+ n-vars n-optionals)) (first rest) env)))

- (when keys (warn "Sorry mathcing of keywords ~S not yet implemented." keys))

+ (when keys (warn "Sorry matching of keywords ~S not yet implemented." keys))

env

))))

-(defmethod unify ((b template) (a list) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a list)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

@@ -363,14 +469,18 @@

;;;---------------------------------------------------------------------------

;;; Vector template methods.

-(defmethod unify ((a vector) (b template) &optional (env (make-empty-environment)))

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

+ &optional (env)

+ &key &allow-other-keys)

(declare (ignore env))

(error 'unification-failure

:format-control "Cannot unify a vector with a non-vector template: ~S ~S."

:format-arguments (list a b)))

-(defmethod unify ((a vector) (b vector-template) &optional (env (make-empty-environment)))

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(let ((template-lambda-list (sequence-template-lambda-list b))

(vl (length a))

)

@@ -381,7 +491,7 @@

:key-variable-test #'valid-template-p

:rest-variable-test #'valid-template-p

)

(let ((n-vars (list-length vars))

(n-optionals (list-length optionals))

)

@@ -401,20 +511,27 @@

))))

-(defmethod unify ((b template) (a vector) &optional (env (make-empty-environment)))

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

;;;---------------------------------------------------------------------------

;;; Array template methods.

-(defmethod unify ((a array) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a array) (b template)

+ &optional (env)

+ &key &allow-other-keys)

(declare (ignore env))

(error 'unification-failure

- :format-control "Cannot unify an array with a non array or non array access template: ~S ~S."

+ :format-control "Cannot unify an array with a non array ~

+ or non array access template: ~S and ~S."

:format-arguments (list a b)))

-(defmethod unify ((b template) (a array) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a array)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

@@ -425,7 +542,9 @@

(let ((row (make-array (first dims)

:displaced-to array

:displaced-index-offset

- (apply #'array-row-major-index array (append indexes (list 0))))))

+ (apply #'array-row-major-index

+ array

+ (append indexes (list 0))))))

(declare (dynamic-extent row)

(type array row))

(untyped-unify row shape-template env)))

@@ -445,7 +564,9 @@

(unify-array-row array (array-dimensions array) shape-template () env))

-(defmethod unify ((a array) (b array-template) &optional (env (make-empty-environment)))

+(defmethod unify ((a array) (b array-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(let ((template-spec (template-spec b)))

(if (= 2 (length template-spec))

@@ -469,10 +590,13 @@

;;;---------------------------------------------------------------------------

;;; Standard object template methods.

-(defmethod unify ((a standard-object) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a standard-object) (b template)

+ &optional (env)

+ &key &allow-other-keys)

(declare (ignore env))

(error 'unification-failure

- :format-control "Cannot unify a standard object with a non standard object template: ~S ~S."

+ :format-control "Cannot unify a standard object with a ~

+ non standard object template: ~S and ~S."

:format-arguments (list a b)))

#|| Old version with heavy syntax

@@ -501,7 +625,8 @@

(defmethod unify ((a standard-object) (b standard-object-template)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(destructuring-bind (class &rest template-slot-specs)

(template-spec b)

(unless (typep a class)

@@ -524,27 +649,34 @@

env))))

-(defmethod unify ((b template) (a standard-object) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a standard-object)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

;;;---------------------------------------------------------------------------

;;; Structure object template methods.

-(defmethod unify ((a structure-object) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a structure-object) (b template)

+ &optional (env)

+ &key &allow-other-keys)

(declare (ignore env))

(error 'unification-failure

- :format-control "Cannot unify a structure object with a non structure object template: ~S ~S."

+ :format-control "Cannot unify a structure object with ~

+ a non structure object template: ~S and ~S."

:format-arguments (list a b)))

(defmethod unify ((a structure-object) (b structure-object-template)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(destructuring-bind (class &rest template-slot-specs)

(template-spec b)

(unless (typep a class)

(error 'unification-failure

- :format-control "Cannot unify an instance of ~S with a template for structure ~S."

+ :format-control "Cannot unify an instance of ~S with a ~

+ template for structure ~S."

:format-arguments (list (class-of a) class)))

(if template-slot-specs

(loop for (reader value-template) on template-slot-specs by #'cddr

@@ -554,41 +686,197 @@

env)))

-(defmethod unify ((b template) (a structure-object) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a structure-object)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

;;;---------------------------------------------------------------------------

;;; Expression template SUBSEQ methods.

-(defmethod unify ((a sequence) (b subseq-template) &optional (env (make-empty-environment)))

+;;; SEQUENCE

+;;; For non LIST and non VECTOR possible SEQUENCE types.

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(destructuring-bind (subseq-kwd from to &rest spec)

(template-spec b)

+ (declare (ignore subseq-kwd))

(let* ((seq-type (type-of a))

- (seq-template-kind (if (symbolp seq-type) seq-type (first seq-type))) ; Stupid FTTB.

+ (seq-template-kind (if (symbolp seq-type)

+ seq-type

+ (first seq-type))) ; Stupid FTTB.

)

+ (unify (subseq a from to)

+ (make-template seq-template-kind `(,seq-template-kind ,@spec))

+ env))))

+;;; LIST

+(defmethod unify ((a list) (b subseq-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (subseq-kwd from to &rest spec)

+ (template-spec b)

+ (declare (ignore subseq-kwd))

(unify (subseq a from to)

- (make-template seq-template-kind `(,seq-template-kind ,@spec))

- env))))

+ (make-template 'list `(list ,@spec))

+ env)))

+;;; VECTOR

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (subseq-kwd from to &rest spec)

+ (template-spec b)

+ (declare (ignore subseq-kwd))

+ (let ((seq-type (type-of a)))

+ (unify (subseq a from to)

+ (make-template seq-type `(,seq-type ,@spec))

+ env))))

-(defmethod unify ((b subseq-template) (a sequence) &optional (env (make-empty-environment)))

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(unify a b env))

;;;---------------------------------------------------------------------------

-;;; Expression template AREF methods.

+;;; Expression templates

+;;; AREF methods.

+(defmethod unify ((a array) (b aref-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (aref-kwd indexes value-template)

+ (template-spec b)

+ (declare (ignore aref-kwd))

+ ;; Missing check on index spec.

+ (unless (consp indexes)

+ (setf indexes (list indexes)))

+ (unify (apply #'aref a indexes) value-template env)))

-(defmethod unify ((a array) (b aref-template) &optional (env (make-empty-environment)))

+;;; Necessary due to standard method sorting.

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

(destructuring-bind (aref-kwd indexes value-template)

(template-spec b)

(declare (ignore aref-kwd))

;; Missing check on index spec.

+ (when (and (consp indexes) (> (length indexes) 1))

+ (error 'unification-failure

+ :format-control "Cannot unify a vector with an element ~

+ too many dimensions down~@

+ (AREF #(...)~{ ~S~})."

+ :format-arguments (list indexes)

+ ))

(unless (consp indexes)

(setf indexes (list indexes)))

(unify (apply #'aref a indexes) value-template env)))

+(defmethod unify ((b aref-template) (a array)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (unify a b env))

+;;; ELT methods.

+;;; LIST and VECTOR methods must be specified separatedly because of

+;;; the UNIFY (VECTOR TEMPLATE) methods above. It is a snag, but a

+;;; relatively small one. Besides, they are more efficient.

+;;; The (SEQUENCE ELT-TEMPLATE) ELT-TEMPLATE method is left for those

+;;; sequences which, according to the ANSI spec may exist and not be

+;;; either VECTOR or LIST.

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (elt-kwd index value-template)

+ (template-spec b)

+ (declare (ignore elt-kwd)

+ (type fixnum index))

+ ;; Missing index check.

+ (unify (elt a index) value-template env)))

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (elt-kwd index value-template)

+ (template-spec b)

+ (declare (ignore elt-kwd)

+ (type fixnum index))

+ ;; Missing index check.

+ (unify (aref a index) value-template env)))

+(defmethod unify ((a list) (b elt-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (elt-kwd index value-template)

+ (template-spec b)

+ (declare (ignore elt-kwd)

+ (type fixnum index))

+ ;; Missing index check.

+ (unify (nth index a) value-template env)))

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

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (unify a b env))

+;;; NTH methods.

+(defmethod unify ((a list) (b nth-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (nth-kwd index value-template)

+ (template-spec b)

+ (declare (ignore nth-kwd))

+ ;; Missing index check.

+ (unify (nth index a) value-template env)))

+(defmethod unify ((b nth-template) (a list)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (unify a b env))

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

+;;; Utilities.

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

+ (handler-case

+ (unify a b env)

+ (unification-failure (c) (values nil c))))

+(defun unify-equations (eqns &optional (env (make-empty-environment)))

+ (loop for (a b) in eqns

+ for result-env = (unify a b env) then (unify a b result-env)

+ finally (return result-env)))

+(defun unify-equations* (lhss rhss &optional (env (make-empty-environment)))

+ (loop for a in lhss

+ for b in rhss

+ for result-env = (unify a b env) then (unify a b result-env)

+ finally (return result-env)))

;;;---------------------------------------------------------------------------

;;; VAR-UNIFY

@@ -650,7 +938,7 @@

;; This is needed because of different precedence rules among lisps

;; in COMPUTE-APPLICABLE-METHODS when NIL has to matched against

;; SYMBOL and LIST.

;; We know (assume) that VAR is not NIL.

nil)

@@ -674,11 +962,18 @@

nil)

+(defmethod occurs-in-p ((var symbol) (pat character) env)

+ (declare (ignore env))

+ nil)

(defmethod occurs-in-p ((var symbol) (pat t) env)

(declare (ignore env))

- (warn "Occurrence test unimplemented for pattern ~S of type ~S; returning false."

+ (warn "Occurrence test unimplemented for pattern ~S of type ~S in variable ~S;~@

+ returning false."

pat

- (type-of pat))

+ (type-of pat)

+ var)

nil)

diff -rN -u old-cl-unification-1/variables.lisp new-cl-unification-1/variables.lisp

--- old-cl-unification-1/variables.lisp 2013-06-14 05:59:04.000000000 +0000

+++ new-cl-unification-1/variables.lisp 2013-06-14 05:59:04.000000000 +0000

@@ -1,10 +1,19 @@

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

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

+;;;; variables.lisp --

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

(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.

-(defun make-var-name (&optional (s (gensym)) (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))

(defun variablep (x)

There once was a man from Nantucket…

RSS