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.
Sun Jul 13 13:17:29 UTC 2008 mantoniotti
* Copyright dates updated.
Sun Jul 13 13:14:56 UTC 2008 mantoniotti
* Added file.
Sun Jul 13 13:10:48 UTC 2008 mantoniotti
* Some modification added. Exported symbols and reverted
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
Sun Jul 13 12:51:14 UTC 2008 mantoniotti
* Added explicit :source-extension to accomodate Allegro CL.
Thu Jul 10 17:39:16 UTC 2008 mantoniotti
* Removed EXPORT of APPLY-SUBSTITUTION as it is already in the DEFPACKAGE.
Fri Nov 9 13:56:40 UTC 2007 mantoniotti
* Changed the position of the disclaimer.
Fri Nov 9 13:47:00 UTC 2007 mantoniotti
* ChangeLog updated.
Fri Nov 9 13:43:20 UTC 2007 mantoniotti
* Made several changes to improve MATCH-CASE (following a note from Ivan
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.
Fri Nov 9 13:35:55 UTC 2007 mantoniotti
* Changed the top comment and added a (:copier nil) option to the
Changed the top comment and added a (:copier nil) option to the
ENVIRONMENT defstruct, as COPY-ENVIRONMENT is defined later in the
file.
Fri Nov 9 13:34:18 UTC 2007 mantoniotti
* Added the new system building files with more meaningful names
Added the new system building files with more meaningful names
w.r.t. the name of the library.
Fri Nov 9 13:30:53 UTC 2007 mantoniotti
* Marked the two system building files as 'obsolete', before removing
Marked the two system building files as 'obsolete', before removing
them from the repository. The new files are prefixed by 'cl-'.
Mon May 21 17:12:58 UTC 2007 mantoniotti
* ChangeLog updated.
Mon May 21 17:11:42 UTC 2007 mantoniotti
* Updated copyrights dates and changed a few instructions in the
Updated copyrights dates and changed a few instructions in the
INSTALLATION file.
Mon May 21 17:10:26 UTC 2007 mantoniotti
* Updated copyrights dates.
Mon May 21 16:55:57 UTC 2007 mantoniotti
* ChangeLog updated.
Mon May 21 12:33:05 UTC 2007 mantoniotti
* See previous message.
Mon May 21 12:29:24 UTC 2007 mantoniotti
* Added file 'apply-substitition.lisp' with a few new functions that are
Added file 'apply-substitition.lisp' with a few new functions that are
a start for the variable substitition operation.
New fixes to the MATCH and MATCH-CASE macros. They should now work as
advertised.
Minor changes to other files: added exports to package file, fixed
.system and .asd files.
Wed Jul 19 21:52:34 UTC 2006 mantoniotti
* Fixed two problems with the unifier machinery.
Fixed two problems with the unifier machinery.
The first one had to do with the matching of NIL against SYMBOL and LIST
in several places: essentially, the problem is incongruencies in the
results of COMPUTE-APPLICABLE-METHODS in these cases. I think I caught
most of them: unification of lists and the occur-check were the obvious
places where things went awry.
The second problem had to do with the reader macro #T. The original
code generated an object at read time, which is not such a good idea.
Now the code generates a call to MAKE-TEMPLATE with is evaluated later.
Incidentally, the reader macro function is now called |sharp-T-reader|, in
order to placate Emacs fontification.
Modified Files:
templates-hierarchy.lisp unifier.lisp
Wed Jul 19 20:28:49 UTC 2006 mantoniotti
* Added missing export.
Tue Oct 25 19:17:33 UTC 2005 mantoniotti
* Fixed problem with the unification of a list with a
Fixed problem with the unification of a list with a
SEQUENCE-TEMPLATE. The implementation was not checking that the
length of the list was compatible with the length of the required
elements in the template.
Apart from that, keyword matching is still unimplemented.
Tue Oct 25 19:08:15 UTC 2005 mantoniotti
* Fixed problem with checking the presence of T and OTHERWISE clauses in
Fixed problem with checking the presence of T and OTHERWISE clauses in
MATCHING.
Mon Jul 25 15:15:08 UTC 2005 mantoniotti
* Minor cleanup.
Fri May 20 16:41:16 UTC 2005 mantoniotti
* Fixed typos.
Fri May 20 16:38:06 UTC 2005 mantoniotti
* Fixed bug in documentation.
Fri May 20 16:33:24 UTC 2005 mantoniotti
* Page updated.
Fri May 20 16:27:05 UTC 2005 mantoniotti
* Incremental change to page.
Fri May 20 16:18:33 UTC 2005 mantoniotti
* Fixed a documentation bug.
Fixed a documentation bug.
Thanks to Norman Werner for spotting it.
Fri May 20 15:47:44 UTC 2005 mantoniotti
* Added link to "Mailing Lists" page.
Fri May 20 15:19:53 UTC 2005 mantoniotti
* Fixed two major bugs reported by Norman Werver. Unification of
Fixed two major bugs reported by Norman Werver. Unification of
strings and symbols and of numers and symbols was not recurring on
VAR-UNIFY, as required; thus
(unify '(?x ?x) '("asd" "qweert"))
and
(unify '(foo ?x baz) '(foo 42 ?x))
would succed.
The two cases are now fixed.
Thu May 19 23:00:18 UTC 2005 mantoniotti
* Year updated.
Thu May 19 22:58:34 UTC 2005 mantoniotti
* File added.
Thu May 19 22:54:27 UTC 2005 mantoniotti
* ChangeLog updated.
Thu May 19 22:52:52 UTC 2005 mantoniotti
* Updated copyright notice.
Thu May 19 22:49:59 UTC 2005 mantoniotti
* Changed the DISCLAIMER parts in the files, in order to clarify the licensing
Changed the DISCLAIMER parts in the files, in order to clarify the licensing
of the code.
Wed Apr 27 21:04:59 UTC 2005 mantoniotti
* Fixed factorial example.
Wed Apr 27 21:04:36 UTC 2005 mantoniotti
* Added IGNORABLE declaration to MATCH macro expansion.
Added IGNORABLE declaration to MATCH macro expansion.
This is useful in quieting various compilers.
Wed Apr 27 20:54:05 UTC 2005 mantoniotti
* Added acknowledgement to Peter Scott.
Wed Apr 27 20:52:09 UTC 2005 mantoniotti
* Fixed bug in condition signaling within MATCH-CASE.
Wed Apr 27 20:44:25 UTC 2005 mantoniotti
* Fixed bugs in COLLECT-TEMPLATE-VARS for NUMBER-TEMPLATEs.
Fixed bugs in COLLECT-TEMPLATE-VARS for NUMBER-TEMPLATEs.
If a variable was present, then the method was not returning a list.
The treatment of constants like PI was also incorrect, as the numeric
value was returned. Retunrning () seems the right thing to do
instead.
Wed Apr 27 20:41:56 UTC 2005 mantoniotti
* Added MATCH-CASE macro. Slightly modified from the version provided
Added MATCH-CASE macro. Slightly modified from the version provided
by Peter Scott.
Wed Apr 27 19:31:18 UTC 2005 mantoniotti
* Added unification.asd file.
Thu Apr 21 15:33:20 UTC 2005 mantoniotti
* Fixed, but not completed, the page.
diff -rN -u old-cl-unification-1/ACKNOWLEDGEMENTS new-cl-unification-1/ACKNOWLEDGEMENTS
--- old-cl-unification-1/ACKNOWLEDGEMENTS 2013-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/ACKNOWLEDGEMENTS 2013-07-24 22:58:30.000000000 +0000
@@ -7,6 +7,7 @@
fixes.
Boldyrev, Ivan
+Brown, Robert
Korablin, Vladimir V.
Leuner, John
McManus, Russell
diff -rN -u old-cl-unification-1/COPYING new-cl-unification-1/COPYING
--- old-cl-unification-1/COPYING 2013-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/COPYING 2013-07-24 22:58:30.000000000 +0000
@@ -1,4 +1,4 @@
-Copyright (c) 2004 Marco Antoniotti
+Copyright (c) 2004-2012 Marco Antoniotti
All rights reserved.
Permission is hereby granted, without written agreement and without
@@ -12,10 +12,10 @@
THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR(S),
HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-THE AUTHOR(S) UNIVERSITY SPECIFICALLY DISCLAIMS ANY WARRANTIES,
-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE
-PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND THE AUTHOR(S) HAVE NO
-OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
-MODIFICATIONS.
+THE AUTHOR(S) UNIVERSITY, COMPANY AND/OR AFFILIATION SPECIFICALLY
+DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND
+THE AUTHOR(S) HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT,
+UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
diff -rN -u old-cl-unification-1/ChangeLog new-cl-unification-1/ChangeLog
--- old-cl-unification-1/ChangeLog 2013-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/ChangeLog 2013-07-24 22:58:30.000000000 +0000
@@ -1,3 +1,103 @@
+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.
diff -rN -u old-cl-unification-1/INSTALLATION new-cl-unification-1/INSTALLATION
--- old-cl-unification-1/INSTALLATION 2013-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/INSTALLATION 2013-07-24 22:58:30.000000000 +0000
@@ -5,18 +5,26 @@
Issuing
- (mk:load-system "unification")
+ (mk:load-system "CL-UNIFICATION")
or
- (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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/README 2013-07-24 22:58:30.000000000 +0000
@@ -1,6 +1,6 @@
CL-UNIFICATION
-Marco Antoniotti 2004
+Marco Antoniotti (c) 2004-2011
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-07-24 22:58:30.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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/apply-substitution.lisp 2013-07-24 22:58:30.000000000 +0000
@@ -1,8 +1,10 @@
-;;; -*- 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.
@@ -70,8 +72,8 @@
finally (return (make-frame result-bindings)))
into frames
finally (return (make-environment :frames frames))))
-
-
+
+
;;; ground-term --
@@ -80,4 +82,4 @@
(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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/cl-unification-lib.asd 2013-07-24 22:58:30.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-07-24 22:58:30.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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/cl-unification.asd 2013-07-24 22:58:30.000000000 +0000
@@ -1,40 +1,56 @@
;;;; -*- Mode: Lisp -*-
-
;;;; cl-unification.asd --
;;;; ASDF system file.
-;;;;===========================================================================
-;;;; Simple stuff that should be built in ASDF.
+;;;; See file COPYING for copyright licensing information.
(defpackage "CL-UNIFICATION-SYSTEM" (:use "CL" "ASDF"))
(in-package "CL-UNIFICATION-SYSTEM")
-(defclass asdf-system-definition-file (asdf:cl-source-file) ())
-(defmethod source-file-type ((c asdf-system-definition-file) (s module)) "asd")
+(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-with-optional-dependencies
+ (: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"
- :pathname "lib-dependent"
- :depends-on ("templates-hierarchy" "unifier")
- :components ((:file "cl-ppcre-template"
- :depends-on (cl-ppcre))
- ))
- #-asdf-with-optional-dependencies
- (asdf-system-definition-file
- "cl-unification-lib")
- ))
+ :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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/cl-unification.system 2013-07-24 22:58:30.000000000 +0000
@@ -3,6 +3,8 @@
;;;; cl-unification.system --
;;;; MK:DEFSYSTEM system file.
+;;;; See file COPYING for copyright licensing information.
+
(mk:defsystem "CL-UNIFICATION"
:source-extension "lisp"
:components ("unification-package"
@@ -20,5 +22,5 @@
)
))
))
-
+
;;; 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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/control-flow.html 2013-07-24 22:58:30.000000000 +0000
@@ -68,7 +68,7 @@
(defun factorial (x)
(<b>match-case</b> (x)
(0 1)
- (#T(number ?n) (factorial (1- ?n)))
+ (#T(number ?n) (* ?n (factorial (1- ?n))))
(otherwise (error "Incorrect match for ~S." x))))
</pre>
</p>
@@ -208,7 +208,7 @@
<div class="content">
<div class="text" style="padding-top: 10px;">
- <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>
</div>
@@ -233,7 +234,7 @@
<tr>
<td colspan="3" valign="bottom" align="right">
<div class="copyright">
- © 2003-2004, Marco Antoniotti, all rights reserved.
+ © 2003-2011, Marco Antoniotti, all rights reserved.
</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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/dictionary.html 2013-07-24 22:58:30.000000000 +0000
@@ -279,7 +279,7 @@
<!--
-;;; Copyright (c) 2004 Marco Antoniotti, All rigths reserved.
+;;; Copyright (c) 2004-2011 Marco Antoniotti, All rigths reserved.
;;;
;;; Permission to use, modify, and redistribute this code is hereby
;;; granted.
@@ -314,7 +314,7 @@
<div class="content">
<div class="text" style="padding-top: 10px;">
- <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>
</div>
@@ -339,7 +339,7 @@
<tr>
<td colspan="3" valign="bottom" align="right">
<div class="copyright">
- © 2003-2004, Marco Antoniotti, all rights reserved.
+ © 2003-2011, Marco Antoniotti, all rights reserved.
</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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/downloads.html 2013-07-24 22:58:30.000000000 +0000
@@ -15,7 +15,7 @@
<div class="navigation">
<a href="index.html" class="navigation-link">Home</a>
| <a href="downloads.html" class="navigation-link-selected">Downloads</a>
- | <a href="links.html" class="navigation-link">Links</a>
+ | <a href="links.html" class="navigation-link">Links</a>
</div>
</div>
<div class="black-line"><img src="images/shim.gif" height="1" width="1"></div>
@@ -41,13 +41,11 @@
completely tested and it is bound to contain errors and omissions.
This documentation may contain errors and omissions as well.</p>
- <p>Finally, the license under which the code is released is not
- settled yet, although the file <tt>COPYING</tt> contains a
- Berkeley-style license. For the time being you are advised to use
- the code at your own risk. No warranty whatsoever is provided, the
- author will not be held responsible for any effect generated by your
- use of the library, and you can put here the scarier extra
- disclaimer you can think of.
+ <p>The file <tt>COPYING</tt> contains a Berkeley-style license. You
+ are advised to use the code at your own risk. No warranty
+ whatsoever is provided, the author will not be held responsible for
+ any effect generated by your use of the library, and you can put
+ here the scarier extra disclaimer you can think of.
</p>
</em>
<hr>
@@ -99,7 +97,7 @@
<div class="content">
<div class="text" style="padding-top: 10px;">
- <h1>News</h1>
+<!-- <h1>News</h1>
<p>News in chronological order, most recent on top.
</p>
@@ -111,7 +109,7 @@
Started the site.
</li>
</ul>
-
+-->
</div>
</div>
@@ -126,7 +124,7 @@
<tr>
<td colspan="3" valign="bottom" align="right">
<div class="copyright">
- © 2003-2004, Marco Antoniotti, all rights reserved.
+ © 2003-2011, Marco Antoniotti, all rights reserved.
</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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/index.html 2013-07-24 22:58:30.000000000 +0000
@@ -15,7 +15,8 @@
<div class="navigation">
<a href="index.html" class="navigation-link-selected">Home</a>
| <a href="downloads.html" class="navigation-link">Downloads</a>
- | <a href="links.html" class="navigation-link">Links</a>
+ | <a href="mailing-lists.html" class="navigation-link">Mailing Lists</a>
+ | <a href="links.html" class="navigation-link">Links</a>
</div>
</div>
<div class="black-line"><img src="images/shim.gif" height="1" width="1"></div>
@@ -33,25 +34,6 @@
<h1>Common Lisp Extensions: UNIFICATION</h1>
-
- <hr>
- <em>
- <p>
- <b>DISCLAIMER:</b> The code associated to these documents is not
- completely tested and it is bound to contain errors and omissions.
- This documentation may contain errors and omissions as well.</p>
-
- <p>Finally, the license under which the code is released is not
- settled yet, although the file <tt>COPYING</tt> contains a
- Berkeley-style license. For the time being you are advised to use
- the code at your own risk. No warranty whatsoever is provided, the
- author will not be held responsible for any effect generated by your
- use of the library, and you can put here the scarier extra
- disclaimer you can think of.
- </p>
- </em>
- <hr>
-
<p>The notion of <em>unification</em> originated in the field of
formal logic (e.g. <a href="#R65">[R65]</a>,) and has been used
extensively in Computer Science and Programming Languages. Most
@@ -304,10 +286,29 @@
<a name="R65">[R56]</a> J. A. Robinson, <i>A machine-oriented logic based on the
resolution principle</i>, Journal of the ACM, Vol. 12, No. 1,
January 1965, Pages 23--49.</p>
+
+
+ <h1></h1>
+ <hr>
+ <em>
+ <p>
+ <b>DISCLAIMER:</b> The code associated to these documents is not
+ completely tested and it is bound to contain errors and omissions.
+ This documentation may contain errors and omissions as well.</p>
+
+ <p>The file <tt>COPYING</tt> contains a Berkeley-style license. You
+ are advised to use the code at your own risk. No warranty
+ whatsoever is provided, the author will not be held responsible for
+ any effect generated by your use of the library, and you can put
+ here the scarier extra disclaimer you can think of.
+ </p>
+ </em>
+ <hr>
+
<!--
-;;; Copyright (c) 2004 Marco Antoniotti, All rigths reserved.
+;;; Copyright (c) 2004-2011 Marco Antoniotti, All rigths reserved.
;;;
;;; Permission to use, modify, and redistribute this code is hereby
;;; granted.
@@ -348,6 +349,10 @@
</p>
<ul>
+ <li><strong>2011-02-20</strong><br>
+ CL-UNIFICATION is now in <a href="www.quicklisp.org">Quicklisp</a>.
+ <li><strong>2007-11-09</strong><br>
+ Updated.
<li><strong>2004-11-04</strong><br>
Updated.
<li><strong>2004-05-05</strong><br>
@@ -369,7 +374,7 @@
<tr>
<td colspan="3" valign="bottom" align="right">
<div class="copyright">
- © 2003-2004, Marco Antoniotti, all rights reserved.
+ © 2004-2012, Marco Antoniotti, all rights reserved.
</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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/links.html 2013-07-24 22:58:30.000000000 +0000
@@ -1,6 +1,6 @@
<html>
<head>
- <title>CLRFI: COMMON LISP Requests for Improvements Links</title>
+ <title>CL Unification Links</title>
<link rel="stylesheet" href="main.css">
</head>
@@ -11,12 +11,10 @@
<td colspan="3">
<div class="header"
style="font-family:=Verdana,Arial,Helvetica; font-size: 18px; color: #41286f;">
- <strong><i>CLRFI: Common Lisp Requests for Improvements Links</i><string>
+ <strong><i>CL Unification Links</i><string>
<div class="navigation">
<a href="index.html" class="navigation-link">Home</a>
- | <a href="doc.html" class="navigation-link">Documents</a>
- | <a href="faq.html" class="navigation-link">FAQ</a>
- | <a href="clrfis.html" class="navigation-link">CLRFI listing</a>
+ | <a href="downloads.html" class="navigation-link">Downloads</a>
| <a href="links.html" class="navigation-link-selected">Links</a>
</div>
</div>
@@ -35,26 +33,18 @@
<h1>Links</h1>
- <p>Here are some links which are pertinent to the CLRFI project.</p>
+ <p>Here are some links which are pertinent to the
+ <strong>CL-UNIFICATION</strong> project.</p>
+ <p>
<ul>
- <li><a href="http://srfi.schemers.org">SRFI</a></li>
-
- <li>Local <strong>Common Lisp</strong> user communities
- <ul>
- <li><a href="http://www.lispnyc.org">LispNYC</a></li>
- <li><a href="http://www.jugtouch.com/~rss/lisp">CRACL</a></li>
- </ul>
- </li>
-
- <li>Software Repositories
- <ul>
- <li><a href="http://www.common-lisp.net">common-lisp.net</a></li>
- <li>...</li>
- </ul>
- </li>
- <li>...</li>
+ <li><a href="http://common-lisp.net">common-lisp.net</a>: the host site.</li>
+ <li><a href="http://clocc.sourceforge.net">CLOCC</a>: the site hosting <strong>MK:DEFSYSTEM</strong>.</li>
+ <li><a href="http://mitpress.mit.edu/sicp">Structure and Interpretation of Computer Programs</a>: the SICP site, where inspiration for the unifier can be found.</li>
+ <li><a href="http://www.norvig.com/paip.html">Paradigms of Artificial Intelligence Programming</a>: the PAIP site, where more inspiration for the unifier can be found.</li>
</ul>
+ </p>
+
<!--
;;; Copyright (c) 2004 Marco Antoniotti, All rigths reserved.
@@ -86,17 +76,26 @@
<div class="content">
<div class="text" style="padding-top: 10px;">
- <h1>News</h1>
+ <!-- <h1>News</h1>
<p>News in chronological order, most recent on top.
</p>
<ul>
+ <li><strong>2005-05-20</strong><br>
+ Updated (but not completed) the page.
+ </li>
+
+ <li><strong>2005-04-20</strong><br>
+ Fixed (but not completed) the page.
+ </li>
+
<li><strong>2004-04-12</strong><br>
Started the site.
</li>
</ul>
-
+-->
+
</div>
</div>
@@ -111,7 +110,7 @@
<tr>
<td colspan="3" valign="bottom" align="right">
<div class="copyright">
- © 2003-2004, Marco Antoniotti, all rights reserved.
+ © 2003-2011, Marco Antoniotti, all rights reserved.
</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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/mailing-lists.html 2013-07-24 22:58:30.000000000 +0000
@@ -55,7 +55,7 @@
<!--
-;;; Copyright (c) 2004-2005 Marco Antoniotti, All rigths reserved.
+;;; Copyright (c) 2004-2011 Marco Antoniotti, All rigths reserved.
;;;
;;; Permission to use, modify, and redistribute this code is hereby
;;; granted.
@@ -90,7 +90,7 @@
<div class="content">
<div class="text" style="padding-top: 10px;">
- <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>
</div>
@@ -117,7 +117,7 @@
<tr>
<td colspan="3" valign="bottom" align="right">
<div class="copyright">
- © 2003-2004, Marco Antoniotti, all rights reserved.
+ © 2003-2011, Marco Antoniotti, all rights reserved.
</div>
</td>
</tr>
diff -rN -u old-cl-unification-1/docs/html/nil-template-class.html new-cl-unification-1/docs/html/nil-template-class.html
--- old-cl-unification-1/docs/html/nil-template-class.html 2013-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/nil-template-class.html 2013-07-24 22:58:30.000000000 +0000
@@ -61,7 +61,7 @@
<h2>Description:</h2>
<p>The NIL-TEMPLATE class denotes those object that are used
- to unify against a VECTOR.</p>
+ to unify against NIL.</p>
<h3>Template Syntax:</h3>
diff -rN -u old-cl-unification-1/docs/html/number-template-class.html new-cl-unification-1/docs/html/number-template-class.html
--- old-cl-unification-1/docs/html/number-template-class.html 2013-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/number-template-class.html 2013-07-24 22:58:30.000000000 +0000
@@ -17,7 +17,7 @@
| <a href="unification-package.html" class="navigation-link">Previous</a>
| <a href="index.html" class="navigation-link">Next</a>
| <a href="downloads.html" class="navigation-link">Downloads</a>
- | <a href="links.html" class="navigation-link">Links</a>
+ | <a href="links.html" class="navigation-link">Links</a>
</div>
</div>
<div class="black-line"><img src="images/shim.gif" height="1" width="1"></div>
@@ -61,7 +61,7 @@
<h2>Description:</h2>
<p>The NUMBER-TEMPLATE class denotes those object that are used
- to unify against a VECTOR.</p>
+ to unify against a NUMBER.</p>
<h3>Template Syntax:</h3>
@@ -132,7 +132,7 @@
<h2>Notes:</h2>
- <p>There is no COMPLEX-NUMBER-TEMPLATE class, although a case for it can be easily made..</p>
+ <p>There is no COMPLEX-NUMBER-TEMPLATE class, although a case for it can be easily made.</p>
</td>
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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/string-template-class.html 2013-07-24 22:58:30.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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/templates.html 2013-07-24 22:58:30.000000000 +0000
@@ -173,7 +173,7 @@
<div class="content">
<div class="text" style="padding-top: 10px;">
- <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>
</div>
@@ -198,7 +198,7 @@
<tr>
<td colspan="3" valign="bottom" align="right">
<div class="copyright">
- © 2003-2004, Marco Antoniotti, all rights reserved.
+ © 2003-2011, Marco Antoniotti, all rights reserved.
</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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/unification-dictionary.html 2013-07-24 22:58:30.000000000 +0000
@@ -38,19 +38,26 @@
<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>
<li><a href="element-template-class.html"><i>Class</i> <b>ELEMENT-TEMPLATE</b></a></li>
- <li><a href="array-template-class.html"><i>Class</i> <b>ARRAY-TEMPLATE</b></a></li>
+ <li><a href="aref-template-class.html"><i>Class</i> <b>AREF-TEMPLATE</b></a></li>
<li><a href="elt-template-class.html"><i>Class</i> <b>ELT-TEMPLATE</b></a></li>
<li><a href="nth-template-class.html"><i>Class</i> <b>NTH-TEMPLATE</b></a></li>
<li><a href="nthcdr-template-class.html"><i>Class</i> <b>NTHCDR-TEMPLATE</b></a></li>
<li><a href="type-template-class.html"><i>Class</i> <b>TYPE-TEMPLATE</b></a>
+
+ <li><a href="array-template-class.html"><i>Class</i> <b>ARRAY-TEMPLATE</b></a></li>
+ <li><a href="nil-template-class.html"><i>Class</i> <b>NIL-TEMPLATE</b></a>
+ <li><a href="number-template-class.html"><i>Class</i> <b>NUMBER-TEMPLATE</b></a></li>
<li><a href="symbol-template-class.html"><i>Class</i> <b>SYMBOL-TEMPLATE</b></a>
+ <li><a href="standard-object-template-class.html"><i>Class</i> <b>STANDARD-OBJECT-TEMPLATE</b></a></li>
+ <li><a href="structure-object-template-class.html"><i>Class</i> <b>STRUCTURE-OBJECT-TEMPLATE</b></a></li>
+
<li><a href="make-template-function.html"><i>Function</i> <b>MAKE-TEMPLATE</b></a>
<li><a href="template-p-function.html"><i>Generic function</i> <b>TEMPLATE-P</b></a>
<li><a href="template-spec-accessor.html"><i>Accessor</i> <b>TEMPLATE-SPEC</b></a>
@@ -64,7 +71,7 @@
<!--
-;;; Copyright (c) 2004 Marco Antoniotti, All rigths reserved.
+;;; Copyright (c) 2004-2005 Marco Antoniotti, All rigths reserved.
;;;
;;; Permission to use, modify, and redistribute this code is hereby
;;; granted.
@@ -72,7 +79,7 @@
;;; will not be held liable etc etc etc etc etc.
-->
- <h2>Site Map</h2>
+<!-- <h2>Site Map</h2> -->
<p>Enjoy!</p>
@@ -99,17 +106,19 @@
<div class="content">
<div class="text" style="padding-top: 10px;">
- <h1>News</h1>
+<!-- <h1>News</h1>
<p>News in chronological order, most recent on top.
</p>
<ul>
+ <li><strong>2005-05-20</strong><br>
+ Page updated.
<li><strong>2004-05-05</strong><br>
- Started the site.
+ Started the page.
</li>
</ul>
-
+-->
</div>
</div>
@@ -124,7 +133,7 @@
<tr>
<td colspan="3" valign="bottom" align="right">
<div class="copyright">
- © 2003-2004, Marco Antoniotti, all rights reserved.
+ © 2003-2011, Marco Antoniotti, all rights reserved.
</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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/unify-function.html 2013-07-24 22:58:30.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 @@
<h2>See Also:</h2>
<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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/unifying-substitutions.html 2013-07-24 22:58:30.000000000 +0000
@@ -162,7 +162,7 @@
<div class="content">
<div class="text" style="padding-top: 10px;">
- <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>
</div>
@@ -187,7 +187,7 @@
<tr>
<td colspan="3" valign="bottom" align="right">
<div class="copyright">
- © 2003-2004, Marco Antoniotti, all rights reserved.
+ © 2003-2011, Marco Antoniotti, all rights reserved.
</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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/docs/html/usci-variable.html 2013-07-24 22:58:30.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>
<link rel="stylesheet" href="main.css">
</head>
@@ -11,7 +11,7 @@
<td colspan="3">
<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>
<div class="navigation">
<a href="index.html" class="navigation-link">Home</a>
| <a href="unification-package.html" class="navigation-link">Previous</a>
@@ -33,7 +33,7 @@
<div class="content">
<div class="text" style="padding-top: 10px;">
- <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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/lambda-list-parsing.lisp 2013-07-24 22:58:30.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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/lib-dependent/cl-ppcre-template.lisp 2013-07-24 22:58:30.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-07-24 22:58:30.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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/match-block.lisp 2013-07-24 22:58:30.000000000 +0000
@@ -1,4 +1,9 @@
-;;; -*- Mode: Lisp -*-
+;;;; -*- Mode: Lisp -*-
+
+;;;; 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")
@@ -7,60 +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 a unification operation.
-MATCH unifies a TEMPLATE and an OBJECT and then sets up a lexical
+ (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 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-"))
- )
- (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)
- )
- ,@forms)
- (unification-failure (uf)
- (if ,errorp
- (signal 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 match-cond (&body clauses)
+ (%match-expander 'match 'cond clauses))
+(defmacro matchf-cond (&body clauses)
+ (%match-expander 'matchf 'cond clauses))
(defmacro matching ((&key errorp
- (default-substitution (make-empty-environment)))
- &rest match-clauses)
- "MATCHING sets up a COND-like environment for multiple template matching clauses.
-The syntax of MATCHING comprises a number of clauses of the form
+ 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
<clause> ::= <regular-clause> | <default-clause>
<regular-clause> ::= ((<template> <form>) &body <forms>)
<default-clause> ::= (t &body <forms>)
@@ -68,62 +228,123 @@
<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)))
- (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 (> 1 (count t match-clauses :key #'first))
- (> 1 (count 'otherwise match-clauses :key #'first)))
- (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.
- )
- `(block matching
- (cond ,@(mapcar (lambda (match-clause match-clause-env-var)
- (build-match-clause match-clause match-clause-env-var))
- match-clauses
- (mapcar (lambda (mc)
- (declare (ignore mc))
- (gensym "UNIFICATION-ENV-")
- )
- match-clauses))
- (,errorp
- (error 'unification-non-exhaustive
- :format-control "Non exhaustive matching."))
- ,@(when default-clause (list default-clause)))))
- ))
+")
+
+
+(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
+ <clause> ::= <regular-clause> | <default-clause>
+ <regular-clause> ::= (<template> &body <forms>)
+ <default-clause> ::= (t &body <forms>)
+ | (otherwise &body <forms>)
+<form> and <forms> are regular Common Lisp forms.
+<template> is a unification template.
+
+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 macros are those of the last form in
+the first clause that satisfies the match test.
+
+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.
+
+#| Tests
+
+(let ((n 42))
+ (matching ()
+ ((0 n) 1)
+ ((?x n) (* x (1- x)))))
+
+
+(let ((n 42))
+ (match-case (n)
+ (0 1)
+ (?x (* x (1- x)))))
+
+
+(let ((n 42))
+ (match-case (n)
+ (0 1)
+ (otherwise (* n (1- n)))))
+
+(defun fatt (x)
+ (match-case (x :errorp t)
+ (0 1)
+ (#T(number ?n) (* ?n (fatt (1- n))))
+ ))
+|#
-;;; end of file -- math-blocks.lisp --
+;;;; end of file -- math-blocks.lisp --
diff -rN -u old-cl-unification-1/substitutions.lisp new-cl-unification-1/substitutions.lisp
--- old-cl-unification-1/substitutions.lisp 2013-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/substitutions.lisp 2013-07-24 22:58:30.000000000 +0000
@@ -1,8 +1,10 @@
-;;; -*- Mode: Lisp -*-
+;;;; -*- Mode: Lisp -*-
-;;; substitutions.lisp
-;;; General CL structures unifier.
-;;; Substitution definitions.
+;;;; substitutions.lisp --
+;;;; 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.
@@ -24,11 +26,27 @@
(declare (type binding b))
(car b))
+(defun (setf binding-variable) (v b)
+ (declare (type binding b))
+ (setf (car b) v))
+
+
(defun binding-value (b)
(declare (type binding b))
(cdr b))
+(defun (setf binding-value) (v b)
+ (declare (type binding b))
+ (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)
()
)
@@ -40,7 +58,7 @@
;;;---------------------------------------------------------------------------
;;; Frames.
-(defstruct frame
+(defstruct (frame (:constructor make-frame (&optional bindings)))
(bindings () :type bindings))
(defun empty-frame-p (f)
@@ -61,11 +79,19 @@
(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.
-(defstruct (environment (:print-object print-environment))
+(defstruct (environment (:print-object print-environment)
+ (:copier nil))
(frames () :type list))
(defun print-environment (env stream)
@@ -89,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 empty-environment-p (env &aux (env-frames (environment-frames env)))
+(defun pop-frame (env)
(declare (type environment env))
- (and (= 1 (list-length env-frames))
- (empty-frame-p (first env-frames))))
+ (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)
+ (declare (type environment env))
+ (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))
@@ -119,11 +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))
-;;; end of file -- substitutions.lisp --
+(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)
+ 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-07-24 22:58:30.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-07-24 22:58:30.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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/templates-hierarchy.lisp 2013-07-24 22:58:30.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)
@@ -219,19 +232,6 @@
(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)
@@ -281,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))
@@ -308,8 +311,8 @@
-
-;;; Implementation.
+;;;;===========================================================================
+;;;; Implementation.
;;; Symbol Templates.
;;; Specification is
@@ -342,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
;;;
@@ -428,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))))
@@ -485,10 +513,13 @@
(let ((template (number-template-number template)))
(etypecase template
(number ())
- (symbol (cond ((variablep template) template)
+ (symbol (cond ((and (variablep template) (not (variable-any-p template)))
+ (list template))
((and (boundp template)
(numberp (symbol-value template)))
- (symbol-value template))
+ ;; This handles cases like #T(number pi)
+ ;; It may be too broad, but for the time being it seems ok.
+ nil)
(t
(error "Invalid number template ~S." template)))))))
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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/test/unification-tests.lisp 2013-07-24 22:58:30.000000000 +0000
@@ -1,12 +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.
+
+(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")
-(use-package "UNIFY")
-(use-package "UTIL.TEST")
+;; 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)))
@@ -38,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"))))
)
@@ -97,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
@@ -106,6 +113,8 @@
)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
(defclass test1 ()
((a :initarg :a :accessor a)
(b :initarg :b :accessor b)))
@@ -113,6 +122,8 @@
(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) (_ _ _))
@@ -187,6 +198,12 @@
)
+(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)
@@ -195,16 +212,85 @@
collect (match-case (b)
('(:c ?c) ?c)
('(:d ?d) ?d)
- (otherwise (error "error-inner")))))
- (otherwise (error "error-outer"))))
-
-(with-tests (:name "control flow")
- (test-error (nested-match-cases '(:a 42 :b 33)) :announce t)
+ (otherwise (error 'inner-error)))))
+ (otherwise (error 'outer-error))))
- (test-error (nested-match-cases '(:a 42 :b (33 42))) :announce t)
+(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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/unification-package.lisp 2013-07-24 22:58:30.000000000 +0000
@@ -1,22 +1,90 @@
-;;; -*- Mode: Lisp -*-
+;;;; -*- Mode: Lisp -*-
-(defpackage "CL.EXT.DACF.UNIFICATION" (:use "CL")
- (:nicknames "UNIFY")
+;;;; unification-package.lisp --
+;;;; Package definition for the CL-UNIFICATION library.
+;;;;
+;;;; Copyright (c) 2004-2011 Marco Antoniotti
+;;;; 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"
+
+ "APPLY-SUBSTITUTION"
+
+ "UNIFICATION-FAILURE"
+ "UNIFICATION-VARIABLE-UNBOUND"
+ )
+
+ (:export
+ "ENVIRONMENT"
+ "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"
- "MAKE-EMPTY-ENVIRONMENT")
+ "V?"
+
+ "NEW-VAR"
+ "VARIABLEP"
+ "VARIABLE-ANY-P"
+ )
+
(:export
"MATCH"
- "MATCHING"))
+ "MATCHF"
+ "MATCH-COND"
+ "MATCHF-COND"
+ "MATCHING"
+ "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.system new-cl-unification-1/unification.system
--- old-cl-unification-1/unification.system 2013-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/unification.system 1970-01-01 00:00:00.000000000 +0000
@@ -1,12 +0,0 @@
-;;; -*- Mode: Lisp -*-
-
-(mk:defsystem "UNIFICATION"
- :components ("unification-package"
- "variables"
- "substitutions"
- "lambda-list-parsing"
- "templates-hierarchy"
- "unifier"
- "match-block"))
-
-;;; 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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/unifier.lisp 2013-07-24 22:58:30.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,43 +82,75 @@
:format-arguments (list a b))))
-(defparameter *unify-string-case-insensitive-p* nil)
+(defparameter *unify-string-case-sensitive-p* t)
-(defmethod unify ((a string) (b string) &optional (env (make-empty-environment)))
+(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))
+ &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)
(t
(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) (extend-environment a b env))
+ ((variablep a) (var-unify a b env))
(t (error 'unification-failure
- :format-control "Cannot unify a symbol with a string: ~S ~S."
- :format-arguments (list a b)))))
+ :format-control "Cannot unify a symbol with a string: ~S ~S."
+ :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) (extend-environment a b env))
+ ((variablep a) (var-unify a b env))
(t (error 'unification-failure
:format-control "Cannot unify a string with a symbol: ~S ~S."
: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) (extend-environment a b 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) (extend-environment a b 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,9 +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)))))
@@ -239,38 +304,59 @@
;;;---------------------------------------------------------------------------
;;; NIL special unification methods.
-(defmethod unify ((x null) (nt nil-template) &optional (env (make-empty-environment)))
+(defmethod unify ((x null) (y null)
+ &optional (env (make-empty-environment))
+ &key &allow-other-keys)
+ env)
+
+
+(defmethod unify ((x null) (nt nil-template)
+ &optional (env (make-empty-environment))
+ &key &allow-other-keys)
env)
-(defmethod unify ((nt nil-template) (x null) &optional (env (make-empty-environment)))
+(defmethod unify ((nt nil-template) (x null)
+ &optional (env (make-empty-environment))
+ &key &allow-other-keys)
env)
-(defmethod unify ((nt1 nil-template) (nt2 nil-template) &optional (env (make-empty-environment)))
+(defmethod unify ((nt1 nil-template) (nt2 nil-template)
+ &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))
@@ -278,46 +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))
)
@@ -328,22 +442,26 @@
: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 (list-length vars)) vars env))
+ (env (unify (subseq a 0 (min ll (list-length vars)))
+ vars
+ env))
)
(when (and optionals (>= ll (+ n-vars n-optionals)))
(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))
@@ -351,13 +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))
)
@@ -368,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))
)
@@ -388,19 +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))
@@ -411,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)))
@@ -431,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))
@@ -445,7 +580,7 @@
;; Template is (array (['*' | <element type>] [<dimension spec>]) <shape template>)
(destructuring-bind (array-kwd type-spec shape-template)
template-spec
- (declare (ignore array-kwd))
+ (declare (ignore array-kwd type-spec))
;; Missing check for type-spec.
(unify-array-rows a shape-template env))
)))
@@ -455,12 +590,16 @@
;;;---------------------------------------------------------------------------
;;; 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
+#|| Old version with heavy syntax
(defmethod unify ((a standard-object) (b standard-object-template)
&optional (env (make-empty-environment)))
(destructuring-bind (class &rest template-slot-specs)
@@ -482,11 +621,12 @@
then (slot-spec-unify accessor-spec reader value-template mgu)
finally (return mgu))
env))))
-|#
+||#
(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)
@@ -509,26 +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
@@ -538,39 +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))))))
+ (unify (subseq a from to)
+ (make-template seq-template-kind `(,seq-template-kind ,@spec))
+ env))))
+
+;;; LIST
-(defmethod unify ((b subseq-template) (a sequence) &optional (env (make-empty-environment)))
+(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 '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))
+ &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
@@ -595,7 +901,7 @@
-#|
+#||
(defmethod occurs-in-p ((var symbol) pat env)
(cond ((variablep pat)
(or (eq var pat)
@@ -610,7 +916,8 @@
(occurs-in-p var (rest pat) env)))
(t
(error "unimplemented"))))
-|#
+||#
+
(defmethod occurs-in-p ((var symbol) (pat symbol) env)
(when (variablep pat)
@@ -621,10 +928,21 @@
(occurs-in-p var value env)))
)))
+
(defmethod occurs-in-p ((var symbol) (pat list) env)
(or (occurs-in-p var (first pat) env)
(occurs-in-p var (rest pat) env)))
+
+(defmethod occurs-in-p ((var symbol) (pat null) env)
+ ;; 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)
+
+
(defmethod occurs-in-p ((var symbol) (pat array) env)
(loop for i from 0 below (array-total-size pat)
thereis (occurs-in-p var (row-major-aref pat i) env)))
@@ -644,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-07-24 22:58:30.000000000 +0000
+++ new-cl-unification-1/variables.lisp 2013-07-24 22:58:30.000000000 +0000
@@ -1,7 +1,21 @@
-;;; -*- 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 "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)
(and (symbolp x)
(or (char= (char (symbol-name x) 0) #\?)