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

* Added TIMESTAMP.

+20120116

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

* Copyright updated.

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

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

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

* Copyright updated.

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

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

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

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

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

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

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

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

Change the documentation.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

+

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

+ code that uses them is correctly indented by editors.

+

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

* Copyright updated.

- <h1>News</h1>

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

-

+-->

+ [_$_]

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

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

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

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

- <h1>News</h1>

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

-

+-->

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

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

- <h1>News</h1>

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

-

+-->

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

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

- <h1>News</h1>

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

-

+-->

+ [_$_]

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

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

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

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

- <h1>News</h1>

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

-

+-->

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

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

- <h1>News</h1>

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

-

+-->

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

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

- <h1>News</h1>

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

-

+-->

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

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

- <h1>News</h1>

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

-

+-->

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

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

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

* Updated copyright info and a News.

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

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

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

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

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

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

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

* ChangeLog updated.

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

+

+ * .cvsignore: Updated.

+

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

+ Removed Files:

+ Thumbs.db Thumbs.db:encryptable

+

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

+

+ * .cvsignore: Updated.

+

+ * variables.lisp, unifier.lisp:

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

+

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

+

+ * templates-hierarchy.lisp:

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

+

+ * substitutions.lisp:

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

+

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

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

+

+ * ACKNOWLEDGEMENTS: Acknowledgements updated.

+

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

+

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

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

+ with ~@<newline> format directives.

+

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

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

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

+

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

* Remove Thumbs.db and friends

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

* Exported a few more symbols.

- (:export

- "ENABLE-TEMPLATE-READER"

- "MAKE-TEMPLATE"

- "TEMPLATEP"

- "TEMPLATE-SPEC")

-

- "FIND-VARIABLE-VALUE"

- "V?"

- "MAKE-EMPTY-ENVIRONMENT"

- "ENVIRONMENT-P")

+ "ENVIRONMENT-P"

+ "MAKE-EMPTY-ENVIRONMENT"

+ "EMPTY-ENVIRONMENT-P"

+ "MAKE-SHARED-ENVIRONMENT"

+ "COPY-ENVIRONMENT"

+ [_$_]

+ "PUSH-FRAME"

+ "POP-FRAME"

+

+ "BINDING-VARIABLE"

+ "BINDING-VALUE"

+

+ "EXTEND-ENVIRONMENT"

+ "FILL-ENVIRONMENT"

+ "FILL-ENVIRONMENT*"

+

+ "FIND-VARIABLE-VALUE"

+ "V?"

+

+ "NEW-VAR"

+ "VARIABLEP"

+ "VARIABLE-ANY-P"

+ )

+ (:export

+ "ENABLE-TEMPLATE-READER"

+ "MAKE-TEMPLATE"

+ "TEMPLATEP"

+ "TEMPLATE-SPEC"

+

+ "COLLECT-TEMPLATE-VARS"

+ )

+

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

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

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

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

-;;; substitutions.lisp

-;;; General CL structures unifier.

-;;; Substitution definitions.

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

+;;;; General CL structures unifier.

+;;;; Substitution definitions.

+;;;;

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

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

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

+;;;;

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

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

+

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

+

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

+[_^M_][_$_]

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

+[_^M_][_$_]

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

+

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

+

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

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

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

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

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

+

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

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

+

+;;;; variables.lisp --

+

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

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

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

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

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

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

+

+

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

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

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

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

+ (declare (type environment env))

-(defun make-shared-environment (env)

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

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

+ (declare (type environment env))

+ (make-environment :frames (if pushp

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

+ (environment-frames env))))

+

+(defun push-frame (env)

+ (declare (type environment env))

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

+

+(defun pop-frame (env)

+ (declare (type environment env))

+ (pop (environment-frames env)))

+

- (terpri out)

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

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

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

+ (if (empty-environment-p env)

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

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

+ for fr in (environment-frames env)

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

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

+ do (dump-frame fr out)

+ do (terpri out)

+ )))

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

* Acknowledgements updated.

+Brown, Robert

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

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

with ~@<newline> format directives.

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

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

+ ~@<space><newline>

+

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

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

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

+

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

+

- [_$_]

- [_$_]

+

+

- [_$_]

+

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

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

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

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

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

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

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

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

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

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

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

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

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

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

- [_^M_][_$_]

+[_^M_][_$_]

- [_$_]

+

- [_$_]

+

- [_$_]

+

- [_$_]

+

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

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

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

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

+

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

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

+

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

+ :multiple-values t)

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

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

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

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

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

+

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

+

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

+

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

* Add cl-unification-test.asd

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

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

+

+

+(in-package #:asdf)

+

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

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

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

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

+

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

+ ()

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

+

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

+ nil)

+

+

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

+

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

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

+

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

+

+(defsystem #:cl-unification-test

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

+ :components

+ ((:module "test"

+ :components

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

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

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

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

-#+allegro (require :tester)

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

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

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

+

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

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

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

-(cl:defpackage "UNIFY.TESTS"

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

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

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

before the forms are read. This fixes compilation of

file unification-tests.lisp.

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

+

+)

+

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

* Copyright dates updated.

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

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

-Marco Antoniotti (c) 2004-2008

+Marco Antoniotti (c) 2004-2011

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

* ChangeLog updated.

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

+

+ * unifier.lisp:

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

+ that prevented the correct unification of:

+

+ (?x ?y a)

+

+ with

+

+ (?y ?x ?x)

+

+ * substitutions.lisp:

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

+

+ * .cvsignore: Added .cvsignore file.

+

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

+

+ * ChangeLog: ChangeLog updated.

+

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

+

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

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

+

+ * unifier.lisp: Minor cosmetic changes.

+

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

+

+ * templates-hierarchy.lisp:

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

+ STRUCTURE-OBJECT and STANDARD-OBJECT templates.

+

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

+

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

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

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

+;;; Simple debugging.

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

+ (declare (type frame f))

+ (terpri out)

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

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

+ )

+

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

+ (declare (type environment env))

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

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

* Pull variable binding out of %match-expander

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

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

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

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

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

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

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

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

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

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

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

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

+[_^M_][_$_]

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

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

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

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

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

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

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

* Marginally more straightforward?

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

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

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

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

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

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

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

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

+ (values t boolean))

+ find-variable-value)

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

- find-variable-value

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

* Fix export of lib-dependent symbols

-

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

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

-

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

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

-

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

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

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

+ t)

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

+ nil)

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

+ (and (load-date component)

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

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

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

+ (setf (load-date component)

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

- (:file "apply-substitution")

- #+asdf-with-optional-dependencies

- (:module "lib-dependent"

- :pathname "lib-dependent"

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

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

- :depends-on (cl-ppcre))

- ))

- #-asdf-with-optional-dependencies

- (asdf-system-definition-file

- "cl-unification-lib")

- ))

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

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

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

+ (:module "lib-dependent"

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

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

+ (:module "lib-dependent"

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

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

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

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

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

* Whoops. Typo in test.

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

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

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

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

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

+#+asdf-system-connections

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

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

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

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

+

+;;;; Set up a named-readtable

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

+

+(named-readtables:defreadtable template-readtable

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

+ (:merge :common-lisp))

+

+ #+named-readtables

+ (:export

+ "TEMPLATE-READTABLE")

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

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

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

+ (:file "template-reader")

+;;; Setting up the reader macro.

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

+

+;;; 20080711 MA:

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

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

+

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

+ (declare (ignore subchar arg))

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

+ (typecase spec

+ (null (make-template nil spec))

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

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

+

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

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

+

+

+#||

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

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

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

+;;;

+;;; 20080713 MA

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

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

+

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

+ (declare (ignore subchar arg))

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

+ (typecase spec

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

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

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

+ ))

+||#

+

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

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

+

+

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

+

+(defun rewrite-template-spec (spec)

+ "Rewrites a template specification.

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

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

+

+ (typecase spec

+ (atom `',spec)

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

+ spec

+ (case head

+ (quote spec)

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

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

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

+ )))

+ (t `',spec)))

+

+||#

+

+(defmacro enable-template-reader ()

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

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

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

-;;; Setting up the reader macro.

-

-;;; 20080711 MA:

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

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

-

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

- (declare (ignore subchar arg))

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

- (typecase spec

- (null (make-template nil spec))

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

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

-

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

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

-

-

-#||

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

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

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

-;;;

-;;; 20080713 MA

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

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

-

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

- (declare (ignore subchar arg))

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

- (typecase spec

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

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

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

- ))

-||#

-

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

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

-

-

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

-

-(defun rewrite-template-spec (spec)

- "Rewrites a template specification.

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

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

-

- (typecase spec

- (atom `',spec)

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

- spec

- (case head

- (quote spec)

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

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

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

- )))

- (t `',spec)))

-

-||#

- [_$_]

-

-

+ "ENABLE-TEMPLATE-READER"

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

* Export new MATCH* macros.

+ "MATCH-COND"

+ "MATCHF-COND"

+ "MATCH-ECASE"

+ "MATCHF-ECASE"

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

* Unified docstrings.

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

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

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

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

+[_^M_][_$_]

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

-[_^M_][_$_]

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

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

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

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

-[_^M_][_$_]

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

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

-[_^M_][_$_]

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

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

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

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

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

-[_^M_][_$_]

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

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

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

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

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

+ (warn ":match-named is deprecated. Use :named instead."))[_^M_][_$_]

+ (%match-expander 'matchf[_^M_][_$_]

+ 'nil[_^M_][_$_]

+ `((,template ,object ,@forms))[_^M_][_$_]

+ :default error-value[_^M_][_$_]

+ :named (or named match-named)[_^M_][_$_]

+ :environment substitution[_^M_][_$_]

+ :errorp errorp))[_^M_][_$_]

+[_^M_][_$_]

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

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

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

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

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

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

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

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

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

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

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

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

- (when match-named-p[_^M_][_$_]

- (warn ":match-named is deprecated. Use :named instead."))[_^M_][_$_]

- (%match-expander 'matchf[_^M_][_$_]

- 'nil[_^M_][_$_]

- `((,template ,object ,@forms))[_^M_][_$_]

- :default error-value[_^M_][_$_]

- :named (or named match-named)[_^M_][_$_]

- :environment substitution[_^M_][_$_]

- :errorp errorp))[_^M_][_$_]

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

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

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

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

-[_^M_][_$_]

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

-[_^M_][_$_]

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

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

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

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

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

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

-[_^M_][_$_]

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

-[_^M_][_$_]

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

-[_^M_][_$_]

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

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

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

-[_^M_][_$_]

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

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

-[_^M_][_$_]

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

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

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

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

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

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

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

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

-[_^M_][_$_]

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

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

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

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

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

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

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

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

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

-[_^M_][_$_]

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

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

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

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

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

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

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

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

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

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

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

+[_^M_][_$_]

+[_^M_][_$_]

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

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

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

-[_^M_][_$_]

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

-[_^M_][_$_]

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

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

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

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

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

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

-[_^M_][_$_]

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

-[_^M_][_$_]

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

-[_^M_][_$_]

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

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

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

-[_^M_][_$_]

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

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

-[_^M_][_$_]

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

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

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

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

-[_^M_][_$_]

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

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

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

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

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

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

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

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

+[_^M_][_$_]

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

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

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

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

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

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

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

+[_^M_][_$_]

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

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

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

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

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

+[_^M_][_$_]

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

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

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

+[_^M_][_$_]

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

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

+[_^M_][_$_]

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

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

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

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

+[_^M_][_$_]

Thu Feb 4 07:32:18 UTC 2010 pix@kepibu.org

* Merge all MATCH* macros into a single, unified expansion function

And, because it's now trivial, add MATCH-COND, MATCHF-COND, MATCH-ECASE, and

MATCHF-ECASE.

Still to do: Merge documentation of functions so there's less copy-pasta in the

documentation strings.

-(defun %template-for-match (template)[_^M_][_$_]

- (if (variablep template)[_^M_][_$_]

- `',template ; Logical variables are special-cased.[_^M_][_$_]

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

+(defun %match-expander (template-munger clause-munger clauses[_^M_][_$_]

+ &key default named environment errorp error-form keyform)[_^M_][_$_]

+ "A rather hairy internal function which handles expansion for all the MATCH* macros.[_^M_][_$_]

-(defun %wrap-var-bindings (template environment-var forms)[_^M_][_$_]

- (let* ((template-vars (collect-template-vars template))[_^M_][_$_]

- (bindings (loop for v in template-vars[_^M_][_$_]

- nconc (list `(,v (find-variable-value ',v[_^M_][_$_]

- ,environment-var))[_^M_][_$_]

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

- `(let* ,bindings[_^M_][_$_]

- (declare (ignorable ,@(mapcar #'first bindings)))[_^M_][_$_]

- ,@forms)))[_^M_][_$_]

+template-munger should be either 'match or 'matchf, and will massage the[_^M_][_$_]

+template into the proper form for that macro set.[_^M_][_$_]

+[_^M_][_$_]

+clause-munger should be either 'cond, 'case, or 'nil. This affects the expected[_^M_][_$_]

+syntax of items in clauses as follows:[_^M_][_$_]

+ 'cond: { ((<template> <object>) &body) }+ default-clause[_^M_][_$_]

+ 'case: { (<template> &body) }+ default-clause[_^M_][_$_]

+ 'nil: { (<template> <object> &body) }+ default-clause[_^M_][_$_]

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

+[_^M_][_$_]

+clauses is a list of forms conforming to the syntax just described.[_^M_][_$_]

+[_^M_][_$_]

+default is a single form to be executed if no other forms match.[_^M_][_$_]

+named is the name for a surrounding block.[_^M_][_$_]

+[_^M_][_$_]

+environment is a base environment object which template matches should extend.[_^M_][_$_]

+The new environments created will share frames with this environment, though any[_^M_][_$_]

+additional bindings will be in a new, unshared frame. environment defaults to[_^M_][_$_]

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

+[_^M_][_$_]

+errorp is a single form which will be evaluated to determine if error-form is[_^M_][_$_]

+executed.[_^M_][_$_]

+[_^M_][_$_]

+error-form is a form which is expected to generate an error (e.g., `(error[_^M_][_$_]

+'unification-non-exhaustive)). It defaults to providing the error returned by[_^M_][_$_]

+the last form which failed unification.[_^M_][_$_]

+[_^M_][_$_]

+keyform should be used only for a clause-munger of 'case. It provides the form[_^M_][_$_]

+to evaluate to produce the object for unification in -case macros.[_^M_][_$_]

+[_^M_][_$_]

+*Interaction between default-clause, :errorp + :error-form, and :default[_^M_][_$_]

+[_^M_][_$_]

+This function produces a giant COND form which ends one or more of these[_^M_][_$_]

+assorted \"default\" clauses. They are produced in a very specific order:[_^M_][_$_]

+1. errorp + error-form are tried first. Thus, if errorp is 't, neither the[_^M_][_$_]

+ default-clause in clauses will be reached, nor the :default clause. This is[_^M_][_$_]

+ essentially a hook to produce a pre-user default clause. (e.g., for[_^M_][_$_]

+ MATCH's :errorp)[_^M_][_$_]

+2. The default-clause in clauses, if it exists, will be tried next. Because[_^M_][_$_]

+ clauses is expected to contain user-specified clauses, this is expected to be[_^M_][_$_]

+ the user-specified default clause.[_^M_][_$_]

+3. Finally, the :default clause, if specified, will be tried. This is[_^M_][_$_]

+ essentially a hook to produce a post-user default clause. (e.g., for[_^M_][_$_]

+ -ECASE's error form)[_^M_][_$_]

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

+ (flet ((default-clause-p (clause) (member (first clause) '(t otherwise))))[_^M_][_$_]

+ (let ((match-environment (gensym "MATCH-ENV-"))[_^M_][_$_]

+ (base-environment (gensym "BASE-ENV-"))[_^M_][_$_]

+ (match-error (gensym "MATCH-ERR-"))[_^M_][_$_]

+ (case-keyform (gensym "KEYFORM-"))[_^M_][_$_]

+ (match-clauses (remove-if #'default-clause-p clauses))[_^M_][_$_]

+ (default-clauses (remove-if-not #'default-clause-p clauses)))[_^M_][_$_]

+ (when (or (and (< 1 (length default-clauses))[_^M_][_$_]

+ ;; whether the default clause is the last one[_^M_][_$_]

+ (every #'eq clauses (append match-clauses default-clauses)))[_^M_][_$_]

+ ;; :keyform only applies for 'case[_^M_][_$_]

+ (and keyform (not (eq clause-munger 'case))))[_^M_][_$_]

+ (error 'program-error))[_^M_][_$_]

+ (labels ((ensure-template (template)[_^M_][_$_]

+ (cond (;; Logical variables are special-cased.[_^M_][_$_]

+ (variablep template) `',template)[_^M_][_$_]

+ ;; Same for lists (under matchf)[_^M_][_$_]

+ ((and (eq 'matchf template-munger)[_^M_][_$_]

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

+ (make-instance 'list-template[_^M_][_$_]

+ :spec (cons 'list template)))[_^M_][_$_]

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

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

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

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

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

+ (destructuring-bind (template object &rest body)[_^M_][_$_]

+ clause[_^M_][_$_]

+ (let* ((template (ensure-template template))[_^M_][_$_]

+ (variables (collect-template-vars template)))[_^M_][_$_]

+ `((setf (values ,match-environment ,match-error)[_^M_][_$_]

+ (unify* ,template ,object (make-expanded-environment ,base-environment)))[_^M_][_$_]

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

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

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

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

+ (ecase clause-munger[_^M_][_$_]

+ (cond (destructuring-bind (head . tail) clause[_^M_][_$_]

+ (if (consp head)[_^M_][_$_]

+ (list* (car head) (cadr head) tail)[_^M_][_$_]

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

+ (case (list* (car clause) case-keyform (cdr clause)))[_^M_][_$_]

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

+ `(block ,named[_^M_][_$_]

+ (let ((,match-environment nil)[_^M_][_$_]

+ (,match-error nil)[_^M_][_$_]

+ (,case-keyform ,keyform)[_^M_][_$_]

+ (,base-environment ,(if environment[_^M_][_$_]

+ `(make-shared-environment ,environment)[_^M_][_$_]

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

+ (declare (dynamic-extent ,match-environment ,base-environment)[_^M_][_$_]

+ (ignorable ,case-keyform))[_^M_][_$_]

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

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

+ ,@(when errorp `((,errorp ,(or error-form `(error ,match-error)))))[_^M_][_$_]

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

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

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

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

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

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

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

- (let ((env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]

- (template (%template-for-match template))[_^M_][_$_]

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

- `(block ,match-named[_^M_][_$_]

- (handler-case[_^M_][_$_]

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

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

- ,(%wrap-var-bindings template env-var forms))[_^M_][_$_]

- [_^M_][_$_]

- ;; Yes. The above is sligthly wasteful.[_^M_][_$_]

-[_^M_][_$_]

- (unification-failure (uf)[_^M_][_$_]

- (if ,errorp[_^M_][_$_]

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

- ,error-value))[_^M_][_$_]

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

-[_^M_][_$_]

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

+ (warn ":match-named is deprecated. Use :named instead."))[_^M_][_$_]

+ (%match-expander 'match[_^M_][_$_]

+ 'nil[_^M_][_$_]

+ `((,template ,object ,@forms))[_^M_][_$_]

+ :default error-value[_^M_][_$_]

+ :named (or named match-named)[_^M_][_$_]

+ :environment substitution[_^M_][_$_]

+ :errorp errorp))[_^M_][_$_]

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

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

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

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

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

- (let ((env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]

- (template (cond ((variablep template)[_^M_][_$_]

- `',template) ; Logical variables are special-cased.[_^M_][_$_]

- ((listp template) ; Same for lists.[_^M_][_$_]

- (make-instance 'list-template[_^M_][_$_]

- :spec (cons 'list template)))[_^M_][_$_]

- ;`',template)[_^M_][_$_]

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

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

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

- ;; Logical variables and lists are special cased for convenience.[_^M_][_$_]

- ;; Lists are especially inteded as abbreviation for destructuring.[_^M_][_$_]

- `(block ,match-named[_^M_][_$_]

- (handler-case[_^M_][_$_]

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

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

- ,(%wrap-var-bindings template env-var forms))[_^M_][_$_]

- [_^M_][_$_]

- ;; Yes. The above is sligthly wasteful.[_^M_][_$_]

-[_^M_][_$_]

- (unification-failure (uf)[_^M_][_$_]

- (if ,errorp[_^M_][_$_]

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

- ,error-value))[_^M_][_$_]

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

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

+ (warn ":match-named is deprecated. Use :named instead."))[_^M_][_$_]

+ (%match-expander 'matchf[_^M_][_$_]

+ 'nil[_^M_][_$_]

+ `((,template ,object ,@forms))[_^M_][_$_]

+ :default error-value[_^M_][_$_]

+ :named (or named match-named)[_^M_][_$_]

+ :environment substitution[_^M_][_$_]

+ :errorp errorp))[_^M_][_$_]

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

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

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

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

+[_^M_][_$_]

+(defmacro match-cond (&body clauses)[_^M_][_$_]

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

+ (%match-expander 'match 'cond clauses))[_^M_][_$_]

+[_^M_][_$_]

+(defmacro matchf-cond (&body clauses)[_^M_][_$_]

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

+ (%match-expander 'matchf 'cond clauses))[_^M_][_$_]

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

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

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

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

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

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

- (declare (ignore default-substitution)) ; For the time being.[_^M_][_$_]

- (labels ((%%match%% (clause-var template object forms substitution)[_^M_][_$_]

- (let ((template (%template-for-match template))[_^M_][_$_]

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

- `((setf ,clause-var[_^M_][_$_]

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

- ,(%wrap-var-bindings template clause-var forms))[_^M_][_$_]

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

-[_^M_][_$_]

- (build-match-clause (match-clause match-env-var)[_^M_][_$_]

- (destructuring-bind ((template object) &body forms)[_^M_][_$_]

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

- (%%match%% match-env-var[_^M_][_$_]

- template[_^M_][_$_]

- object[_^M_][_$_]

- forms[_^M_][_$_]

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

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

- (when (or (and (find t match-clauses :key #'first)[_^M_][_$_]

- (find 'otherwise match-clauses :key #'first))[_^M_][_$_]

- (> (count t match-clauses :key #'first) 1)[_^M_][_$_]

- (> (count 'otherwise match-clauses :key #'first) 1))[_^M_][_$_]

- (error 'program-error))[_^M_][_$_]

- (let* ((default-clause (or (find t match-clauses[_^M_][_$_]

- :key #'first)[_^M_][_$_]

- (find 'otherwise match-clauses[_^M_][_$_]

- :key #'first)))[_^M_][_$_]

- (match-clauses (delete default-clause match-clauses)) ; EQL[_^M_][_$_]

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

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

- (env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]

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

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

+ (warn ":matching-named is deprecated. Use :named instead."))[_^M_][_$_]

+ (%match-expander 'match 'cond match-clauses[_^M_][_$_]

+ :errorp errorp[_^M_][_$_]

+ :error-form `(error 'unification-non-exhaustive)[_^M_][_$_]

+ :named (or named matching-named)[_^M_][_$_]

+ :environment default-substitution))[_^M_][_$_]

- `(block ,matching-named[_^M_][_$_]

- (let (,env-var)[_^M_][_$_]

- (declare (dynamic-extent ,env-var))[_^M_][_$_]

- (cond ,@(mapcar (lambda (match-clause)[_^M_][_$_]

- (build-match-clause match-clause[_^M_][_$_]

- env-var))[_^M_][_$_]

- match-clauses)[_^M_][_$_]

- (,errorp[_^M_][_$_]

- (error 'unification-non-exhaustive[_^M_][_$_]

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

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

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

-[_^M_][_$_]

-[_^M_][_$_]

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

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

- (let ((object-var (gensym "OBJECT-VAR-")))[_^M_][_$_]

- `(let ((,object-var ,object))[_^M_][_$_]

- (matching (:errorp ,errorp :default-substitution ,default-substitution :matching-named ,match-case-named)[_^M_][_$_]

- ,@(mapcar[_^M_][_$_]

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

- `(,(if (member (first clause) '(t otherwise))[_^M_][_$_]

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

- (list (first clause) object-var))[_^M_][_$_]

- ,@(rest clause)))[_^M_][_$_]

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

+ (when match-case-named-p[_^M_][_$_]

+ (warn ":match-case-named is deprecated. Use :named instead."))[_^M_][_$_]

+ (%match-expander 'match 'case clauses[_^M_][_$_]

+ :named (or named match-case-named)[_^M_][_$_]

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

+ :errorp errorp[_^M_][_$_]

+ :error-form `(error 'unification-non-exhaustive)[_^M_][_$_]

+ :keyform object))[_^M_][_$_]

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

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

+ (%match-expander 'match 'case clauses[_^M_][_$_]

+ :named named[_^M_][_$_]

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

+ :default `(error 'unification-non-exhaustive)[_^M_][_$_]

+ :keyform object))[_^M_][_$_]

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

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

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

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

- (declare (ignore default-substitution)) ; For the time being.[_^M_][_$_]

- (let* ((object-var (gensym "OBJECT-VAR-"))[_^M_][_$_]

- (otherwise-clause-present-p[_^M_][_$_]

- (member (caar (last clauses)) '(t otherwise)))[_^M_][_$_]

- (non-otherwise-clauses[_^M_][_$_]

- (if otherwise-clause-present-p[_^M_][_$_]

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

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

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

- (if otherwise-clause-present-p[_^M_][_$_]

- (first (last clauses))[_^M_][_$_]

- (when errorp[_^M_][_$_]

- `(t (error 'unification-non-exhaustive[_^M_][_$_]

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

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

- (labels ((generate-matchers (clauses)[_^M_][_$_]

- (if (null clauses)[_^M_][_$_]

- `(progn ,@(rest otherwise-clause))[_^M_][_$_]

- (destructuring-bind (pattern &rest body)[_^M_][_$_]

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

- `(handler-case (matchf (,pattern ,object-var)[_^M_][_$_]

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

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

- ,(generate-matchers (cdr clauses))))))))[_^M_][_$_]

- `(block ,match-case-named[_^M_][_$_]

- (let ((,object-var ,object))[_^M_][_$_]

- ,(generate-matchers non-otherwise-clauses))))))[_^M_][_$_]

+ (when match-case-named-p[_^M_][_$_]

+ (warn ":match-case-named is deprecated. Use :named instead."))[_^M_][_$_]

+ (%match-expander 'matchf 'case clauses[_^M_][_$_]

+ :named (or named match-case-named)[_^M_][_$_]

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

+ :errorp errorp[_^M_][_$_]

+ :error-form `(error 'unification-non-exhaustive)[_^M_][_$_]

+ :keyform object))[_^M_][_$_]

+[_^M_][_$_]

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

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

+ (%match-expander 'matchf 'case clauses[_^M_][_$_]

+ :named named[_^M_][_$_]

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

+ :default `(error 'unification-non-exhaustive)[_^M_][_$_]

+ :keyform object))[_^M_][_$_]

+[_^M_][_$_]

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

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

+

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

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

+(defun nested-matchf-cases (input)

+ (matchf-case (input)

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

+ (loop for b in ?bs

+ collect (matchf-case (b)

+ ((:c ?c) ?c)

+ ((:d ?d) ?d)

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

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

+

-

-

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

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

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

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

+ :test #'equal)

+

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

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

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

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

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

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

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

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

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

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

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

-

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

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

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

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

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

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

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

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

- (error 'inner-error))

- :condition-type 'inner-error)

+ (error 'inner-unification-failure))

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

- (error 'inner-error))

- :condition-type 'inner-error)

+ (error 'inner-unification-failure))

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

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

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

- :condition-type 'inner-error)

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

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

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

- :condition-type 'inner-error)

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

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

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

- :condition-type 'inner-error)

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

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

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

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

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

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

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

* These are no longer failures. Woo!

- :condition-type 'inner-error

- :known-failure t)

+ :condition-type 'inner-error)

- :condition-type 'inner-error

- :known-failure t)

+ :condition-type 'inner-error)

- :condition-type 'inner-error

- :known-failure t)

+ :condition-type 'inner-error)

- :condition-type 'inner-error

- :known-failure t)

+ :condition-type 'inner-error)

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

* Moar tests!

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

+

+

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

+ (error 'inner-error))

+ :condition-type 'inner-error

+ :known-failure t)

+

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

+ (error 'inner-error))

+ :condition-type 'inner-error

+ :known-failure t)

+

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

+ (test :success (matching ()

+ (('x 'y) :fail)

+ (t :success)))

+ (test :success (matching ()

+ (('x 'y) :fail)

+ (otherwise :success)))

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

+ ('y :fail)

+ (t :success)))

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

+ ('y :fail)

+ (otherwise :success)))

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

+ ((y) :fail)

+ (t :success)))

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

+ ((y) :fail)

+ (otherwise :success))))

+

+ (test-error (matching ()

+ (('x 'y) :fail)

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

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

+ :condition-type 'inner-error)

+

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

+ ('(y) :fail)

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

+ ('(?x) x))

+ :condition-type 'inner-error

+ :known-failure t)

+

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

+ ((y) :fail)

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

+ ((?x) x))

+ :condition-type 'inner-error

+ :known-failure t)

+

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

+ ('(a) :fail)

+ ('(b) :fail)

+ ('(?x) x)))

+

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

+ ((a) :fail)

+ ((b) :fail)

+ ((?x) x)))

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

* Consider unexpected errors as test failures

...why is this not default behavior?

+;; nil seems like a lousy default for this

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

+

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

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

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

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

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

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

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

* Make tests file loadable

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

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

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

+#+allegro (require :tester)

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

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

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

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

* DTRT when asdf-system-connections is available

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

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

+

+#+asdf-system-connections

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

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

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

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

+

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

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

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

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

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

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

-

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

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

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

+(cl:defpackage "UNIFY.TESTS"

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

-(use-package "UNIFY")

-(use-package "UTIL.TEST")

-

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

* Handle :case-sensitive properly

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

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

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

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

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

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

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

until the canonical form is decided upon.

- ((char-equal a b)

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

- ((string-equal a b)

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

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

* Fix typo (connot -> cannot)

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

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

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

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

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

* Redefine MATCH-CASE in terms of MATCHING

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

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

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

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

outward as the -case name suggests they should.

That is,

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

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

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

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

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

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

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

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

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

-[_^M_][_$_]

- (declare (ignore default-substitution)) ; For the time being.[_^M_][_$_]

- (let* ((object-var (gensym "OBJECT-VAR-"))[_^M_][_$_]

- (otherwise-clause-present-p[_^M_][_$_]

- (member (caar (last clauses)) '(t otherwise)))[_^M_][_$_]

- (non-otherwise-clauses[_^M_][_$_]

- (if otherwise-clause-present-p[_^M_][_$_]

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

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

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

- (if otherwise-clause-present-p[_^M_][_$_]

- (first (last clauses))[_^M_][_$_]

- (when errorp[_^M_][_$_]

- `(t (error 'unification-non-exhaustive[_^M_][_$_]

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

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

- (labels ((generate-matchers (clauses)[_^M_][_$_]

- (if (null clauses)[_^M_][_$_]

- `(progn ,@(rest otherwise-clause))[_^M_][_$_]

- (destructuring-bind (pattern &rest body)[_^M_][_$_]

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

- `(handler-case (match (,pattern ,object-var)[_^M_][_$_]

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

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

- ,(generate-matchers (cdr clauses))))))))[_^M_][_$_]

- `(block ,match-case-named[_^M_][_$_]

- (let ((,object-var ,object))[_^M_][_$_]

- ,(generate-matchers non-otherwise-clauses))))))[_^M_][_$_]

+ (let ((object-var (gensym "OBJECT-VAR-")))[_^M_][_$_]

+ `(let ((,object-var ,object))[_^M_][_$_]

+ (matching (:errorp ,errorp :default-substitution ,default-substitution :matching-named ,match-case-named)[_^M_][_$_]

+ ,@(mapcar[_^M_][_$_]

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

+ `(,(if (member (first clause) '(t otherwise))[_^M_][_$_]

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

+ (list (first clause) object-var))[_^M_][_$_]

+ ,@(rest clause)))[_^M_][_$_]

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

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

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.

- (match-clauses-env-vars (mapcar (lambda (mc)[_^M_][_$_]

- (declare (ignore mc))[_^M_][_$_]

- (gensym "UNIFICATION-ENV-")[_^M_][_$_]

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

- match-clauses))[_^M_][_$_]

+ (env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]

- (let ,match-clauses-env-vars[_^M_][_$_]

- (declare (dynamic-extent ,@match-clauses-env-vars))[_^M_][_$_]

- (cond ,@(mapcar (lambda (match-clause match-clause-env-var)[_^M_][_$_]

+ (let (,env-var)[_^M_][_$_]

+ (declare (dynamic-extent ,env-var))[_^M_][_$_]

+ (cond ,@(mapcar (lambda (match-clause)[_^M_][_$_]

- match-clause-env-var))[_^M_][_$_]

- match-clauses[_^M_][_$_]

- match-clauses-env-vars)[_^M_][_$_]

+ env-var))[_^M_][_$_]

+ match-clauses)[_^M_][_$_]

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.

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

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

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

+ (handler-case

+ (unify a b env)

+ (unification-failure (c) (values nil c))))

+

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

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

- &rest match-clauses)[_^M_][_$_]

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

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

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

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

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

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.

- ,@(when default-clause (list default-clause))))))[_^M_][_$_]

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

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.

+(defun %wrap-var-bindings (template environment-var forms)[_^M_][_$_]

+ (let* ((template-vars (collect-template-vars template))[_^M_][_$_]

+ (bindings (loop for v in template-vars[_^M_][_$_]

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

+ ,environment-var))[_^M_][_$_]

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

+ `(let* ,bindings[_^M_][_$_]

+ (declare (ignorable ,@(mapcar #'first bindings)))[_^M_][_$_]

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

+[_^M_][_$_]

- (let ((template-vars (collect-template-vars template))[_^M_][_$_]

- (env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]

+ (let ((env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]

- (flet ((generate-var-bindings ()[_^M_][_$_]

- (loop for v in template-vars[_^M_][_$_]

- nconc (list `(,v (find-variable-value ',v[_^M_][_$_]

- ,env-var))[_^M_][_$_]

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

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

- `(block ,match-named[_^M_][_$_]

- (handler-case[_^M_][_$_]

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

- ,@(generate-var-bindings)[_^M_][_$_]

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

- (declare (ignorable ,@(mapcar #'first[_^M_][_$_]

- (generate-var-bindings))))[_^M_][_$_]

- ,@forms)[_^M_][_$_]

+ `(block ,match-named[_^M_][_$_]

+ (handler-case[_^M_][_$_]

+ (let* ((,env-var (unify ,template ,object ,substitution))[_^M_][_$_]

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

+ ,(%wrap-var-bindings template env-var forms))[_^M_][_$_]

- ;; Yes. The above is sligthly wasteful.[_^M_][_$_]

+ ;; Yes. The above is sligthly wasteful.[_^M_][_$_]

- (unification-failure (uf)[_^M_][_$_]

- (if ,errorp[_^M_][_$_]

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

- ,error-value))[_^M_][_$_]

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

+ (unification-failure (uf)[_^M_][_$_]

+ (if ,errorp[_^M_][_$_]

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

+ ,error-value))[_^M_][_$_]

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

- (let ((template-vars (collect-template-vars template))[_^M_][_$_]

- (env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]

+ (let ((env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]

- (flet ((generate-var-bindings ()[_^M_][_$_]

- (loop for v in template-vars[_^M_][_$_]

- nconc (list `(,v (find-variable-value ',v[_^M_][_$_]

- ,env-var))[_^M_][_$_]

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

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

- `(block ,match-named[_^M_][_$_]

- (handler-case[_^M_][_$_]

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

- ,@(generate-var-bindings)[_^M_][_$_]

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

- (declare (ignorable ,@(mapcar #'first[_^M_][_$_]

- (generate-var-bindings))))[_^M_][_$_]

- ,@forms)[_^M_][_$_]

+ `(block ,match-named[_^M_][_$_]

+ (handler-case[_^M_][_$_]

+ (let* ((,env-var (unify ,template ,object ,substitution))[_^M_][_$_]

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

+ ,(%wrap-var-bindings template env-var forms))[_^M_][_$_]

- ;; Yes. The above is sligthly wasteful.[_^M_][_$_]

+ ;; Yes. The above is sligthly wasteful.[_^M_][_$_]

- (unification-failure (uf)[_^M_][_$_]

- (if ,errorp[_^M_][_$_]

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

- ,error-value))[_^M_][_$_]

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

+ (unification-failure (uf)[_^M_][_$_]

+ (if ,errorp[_^M_][_$_]

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

+ ,error-value))[_^M_][_$_]

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

- (let ((template-vars (collect-template-vars template))[_^M_][_$_]

- (template (%template-for-match template))[_^M_][_$_]

+ (let ((template (%template-for-match template))[_^M_][_$_]

- (flet ((generate-var-bindings ()[_^M_][_$_]

- (loop for v in template-vars[_^M_][_$_]

- nconc (list `(,v (find-variable-value[_^M_][_$_]

- ',v[_^M_][_$_]

- ,clause-var))[_^M_][_$_]

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

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

- `((setf ,clause-var[_^M_][_$_]

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

- (let* (,@(generate-var-bindings))[_^M_][_$_]

- ,@forms))[_^M_][_$_]

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

+ `((setf ,clause-var[_^M_][_$_]

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

+ ,(%wrap-var-bindings template clause-var forms))[_^M_][_$_]

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

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.

- (ignore-errors (unify ,template[_^M_][_$_]

- ,object[_^M_][_$_]

- ,substitution)))[_^M_][_$_]

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

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

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

+(defun %template-for-match (template)[_^M_][_$_]

+ (if (variablep template)[_^M_][_$_]

+ `',template ; Logical variables are special-cased.[_^M_][_$_]

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

- (template (if (variablep template)[_^M_][_$_]

- `',template ; Logical variables are special-cased.[_^M_][_$_]

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

+ (template (%template-for-match template))[_^M_][_$_]

- (template (if (variablep template)[_^M_][_$_]

- `',template ; Logical variables are[_^M_][_$_]

- ; special-cased.[_^M_][_$_]

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

+ (template (%template-for-match template))[_^M_][_$_]

Thu Dec 17 17:02:42 UTC 2009 mantoniotti

* ChangeLog updated.

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

+

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

+

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

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

+

+ * unifier.lisp: Minor cosmetic changes.

+

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

+

+ * templates-hierarchy.lisp:

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

+ STRUCTURE-OBJECT and STANDARD-OBJECT templates.

+

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

+

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

+

+ * ChangeLog: ChangeLog updated.

+

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

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

+ dependency form CL-PPCRE optional.

+

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

+

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

+ Removed REQUIRE of CL-PPCRE. Too brittle.

+

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

+

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

- (multiple-value-bind (m-start m-end r-starts r-ends)

- (cl-ppcre:scan (scanner re-t) s :start start :end end)

- ;; Maybe SCAN-TO-STRINGS would be simpler to use...

- (declare (type (integer 0 #.most-positive-fixnum) m-start m-end)

- (type (vector (integer 0 #.most-positive-fixnum)) r-starts r-ends))

- (unless (and (= start m-start) (= m-end end))

+ (multiple-value-bind (matched-p strings)

+ (cl-ppcre:scan-to-strings (scanner re-t) s :start start :end end)

+ (unless matched-p

- (loop for r-start across r-starts

- for r-end across r-ends

- for r-string of-type string = (subseq s r-start r-end)

+ (loop for r-string of-type string across strings

Thu Dec 17 16:44:46 UTC 2009 mantoniotti

* Minor cosmetic changes.

-(defmethod untyped-unify ((as list) (bs vector) &optional (env (make-empty-environment)))

+(defmethod untyped-unify ((as list) (bs vector)

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

-(defmethod untyped-unify ((as vector) (bs list) &optional (env (make-empty-environment)))

+(defmethod untyped-unify ((as vector) (bs list)

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

- (when keys (warn "Sorry mathcing of keywords ~S not yet implemented." keys))

+ (when keys (warn "Sorry matching of keywords ~S not yet implemented." keys))

Thu Dec 17 16:43:51 UTC 2009 mantoniotti

* Exported MATCHF-CASE.

- "MATCH-CASE")

+ "MATCH-CASE"

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

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

+

+

+

+

+(defun structure-object-template-class (x)

+ (and (structure-object-template-p x)

+ (first (template-spec x))))

+

+(defun standard-object-template-class (x)

+ (and (standard-object-template-p x)

+ (first (template-spec x))))

+

Thu Dec 17 16:41:38 UTC 2009 mantoniotti

* Added MATCHF* macros.

+[_^M_][_$_]

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

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

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

+[_^M_][_$_]

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

+[_^M_][_$_]

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

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

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

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

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

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

+[_^M_][_$_]

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

+[_^M_][_$_]

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

+[_^M_][_$_]

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

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

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

+[_^M_][_$_]

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

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

+[_^M_][_$_]

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

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

+any default clause. Otherwise, the default clause behaves as a[_^M_][_$_]

+standard CASE default clause. The default value of ERRORP is NIL.[_^M_][_$_]

+[_^M_][_$_]

+MATCHF-CASE behaves like MATCH-CASE, but the patterns are not[_^M_][_$_]

+evaluated (i.e., it relies on MATCHF instead of MATCH to construct the[_^M_][_$_]

+macro expansion.[_^M_][_$_]

+"[_^M_][_$_]

+ (declare (ignore default-substitution)) ; For the time being.[_^M_][_$_]

+ (let* ((object-var (gensym "OBJECT-VAR-"))[_^M_][_$_]

+ (otherwise-clause-present-p[_^M_][_$_]

+ (member (caar (last clauses)) '(t otherwise)))[_^M_][_$_]

+ (non-otherwise-clauses[_^M_][_$_]

+ (if otherwise-clause-present-p[_^M_][_$_]

+ (butlast clauses)[_^M_][_$_]

+ clauses))[_^M_][_$_]

+ (otherwise-clause[_^M_][_$_]

+ (if otherwise-clause-present-p[_^M_][_$_]

+ (first (last clauses))[_^M_][_$_]

+ (when errorp[_^M_][_$_]

+ `(t (error 'unification-non-exhaustive[_^M_][_$_]

+ :format-control "Non exhaustive matching.")))))[_^M_][_$_]

+ )[_^M_][_$_]

+ (labels ((generate-matchers (clauses)[_^M_][_$_]

+ (if (null clauses)[_^M_][_$_]

+ `(progn ,@(rest otherwise-clause))[_^M_][_$_]

+ (destructuring-bind (pattern &rest body)[_^M_][_$_]

+ (car clauses)[_^M_][_$_]

+ `(handler-case (matchf (,pattern ,object-var)[_^M_][_$_]

+ ,@body)[_^M_][_$_]

+ (unification-failure ()[_^M_][_$_]

+ ,(generate-matchers (cdr clauses))))))))[_^M_][_$_]

+ `(block ,match-case-named[_^M_][_$_]

+ (let ((,object-var ,object))[_^M_][_$_]

+ ,(generate-matchers non-otherwise-clauses))))))[_^M_][_$_]

+[_^M_][_$_]

Fri Apr 17 22:44:17 UTC 2009 mantoniotti

* ChangeLog updated.

+2009-04-18 author <author@Macintosh-9.local>

+

+ * cl-unification.system, cl-unification.asd:

+ System definitions files (.asd and .system) modified in order to make

+ dependency form CL-PPCRE optional.

+

+ * lib-dependent/cl-ppcre-template.system: File added.

+

+ * lib-dependent/cl-ppcre-template.lisp:

+ Removed REQUIRE of CL-PPCRE. Too brittle.

+

+ * cl-unification-lib.asd: File added.

+

+2009-04-17 author <author@Macintosh-9.local>

+

+ * unification-package.lisp:

+ Added a few exports and changed the actual package name (i.e., I put

+ my money where my mouth is; the "published" package name is now a

+ nickname).

+

+ * apply-substitution.lisp:

+ Fixed a couple of snags. APPLY-SUBSTITUTION was not applied

+ recursively and it was barfing on numbers.

+ Current version is still incomplete, but it serves as a template for

+ further development.

+

+2009-04-15 author <author@Macintosh-9.local>

+

+ * ChangeLog: ChangeLog updated.

+

+ * lib-dependent/cl-ppcre-template.lisp, test/unification-tests.lisp:

+ Modified Files:

+ test/unification-tests.lisp

+ Added Files:

+ lib-dependent/cl-ppcre-template.lisp

+

+ The cl-ppcre-template reuses E. Weitz's wonderful CL-PPCRE library

+ to provide a seamless (YMMV) reuse of regular expressions within

+ CL-UNIFICATION.

+

+ * templates-hierarchy.lisp: Added LAMBDA-TEMPLATE.

+

+ * substitutions.lisp:

+ Added some functionality to extract all variables and/or all values

+ from an environment or a frame.

+

+ * match-block.lisp:

+ Added MATCHF (whose name may change) to simplify the

+ 'destructuring-bind'-like syntax and behavior of the matching

+ facilities.

+

+ * COPYING: Dates updated.

+

+ * unifier.lisp:

+ Major API change to 'unify'. It now accepts keywords. Old code

+ shouls not be affected, but new code is now more flexible. Look the

+ the STRING and (new) CHARACTER methods to see how this change is

+ affecting the code.

+

+ * variables.lisp: Some 'diff' unfathomable change happened.

+

+ * unification-package.lisp: Added exports of a few symbols.

+

+ * cl-unification.system, cl-unification.asd:

+ Fixed a few snags and added "lib-dependent" module.

+

+ * apply-substitution.lisp: Added some functionality and comments.

+

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.

-(asdf:defsystem cl-unification

- :author "Marco Antoniotti"

- :serial t

- :components ((:file "unification-package")

- (:file "variables")

- (:file "substitutions")

- (:file "lambda-list-parsing")

- (:file "templates-hierarchy")

- (:file "unifier")

- (:file "match-block")

- (:file "apply-substitution")

- (:module "lib-dependent"

- :depends-on ("templates-hierarchy" "unifier")

- :components (

- #+cl-ppcre

- (:file "cl-ppcre-template")

- ))))

+;;;;===========================================================================

+;;;; Simple stuff that should be built in ASDF.

+

+(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")

+

+

+(asdf:defsystem :cl-unification

+ :author "Marco Antoniotti"

+ :serial t

+ :components ((:file "unification-package")

+ (:file "variables")

+ (:file "substitutions")

+ (:file "lambda-list-parsing")

+ (:file "templates-hierarchy")

+ (:file "unifier")

+ (:file "match-block")

+ (:file "apply-substitution")

+ #+asdf-with-optional-dependencies

+ (:module "lib-dependent"

+ :pathname "lib-dependent"

+ :depends-on ("templates-hierarchy" "unifier")

+ :components ((:file "cl-ppcre-template"

+ :depends-on (cl-ppcre))

+ ))

+ #-asdf-with-optional-dependencies

+ (asdf-system-definition-file

+ "cl-unification-lib")

+ ))

- :source-extension "lisp"

- :components ("unification-package"

- "variables"

- "substitutions"

- "lambda-list-parsing"

- "templates-hierarchy"

- "unifier"

- "match-block"

- "apply-substitution"

- (:module "lib-dependent"

- :depends-on ("templates-hierarchy" "unifier")

- :components (

- #+cl-ppcre

- (:file "cl-ppcre-template")

- ))

- ))

+ :source-extension "lisp"

+ :components ("unification-package"

+ "variables"

+ "substitutions"

+ "lambda-list-parsing"

+ "templates-hierarchy"

+ "unifier"

+ "match-block"

+ "apply-substitution"

+ (:module "lib-dependent"

+ :depends-on ("templates-hierarchy" "unifier")

+ :components ((:subsystem "cl-ppcre-template"

+ :non-required-p t

+ )

+ ))

+ ))

Fri Apr 17 22:40:29 UTC 2009 mantoniotti

* Removed REQUIRE of CL-PPCRE. Too brittle.

-(require "CL-PPCRE")

-

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).

-;;; -*- 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-2009 Marco Antoniotti

+;;;; See file COPYING for licensing information.

+

+

+(defpackage "IT.UNIMIB.DISCO.MA.CL.EXT.DACF.UNIFICATION" (:use "CL")

+ (:nicknames "CL.EXT.DACF.UNIFICATION" "UNIFY" "unify")

+

+ #+cl-ppcre

+ (:export

+ "REGULAR-EXPRESSION"

+ "REGEXP")

-;;; end of file -- unification-package.lisp --

+;;;; end of file -- unification-package.lisp --

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.

+(defmethod apply-substitution ((s environment) (n number) &optional exclude-vars)

+ (declare (ignore exclude-vars))

+ n)

+

+

- (cond (foundp val)

+ (cond (foundp (apply-substitution substitution val exclude-vars))

Wed Apr 15 14:33:35 UTC 2009 mantoniotti

* ChangeLog updated.

+2009-04-15 author <author@paniscia.pd.disco.unimib.it>

+

+ * lib-dependent/cl-ppcre-template.lisp, test/unification-tests.lisp:

+ Modified Files:

+ test/unification-tests.lisp

+ Added Files:

+ lib-dependent/cl-ppcre-template.lisp

+

+ The cl-ppcre-template reuses E. Weitz's wonderful CL-PPCRE library

+ to provide a seamless (YMMV) reuse of regular expressions within

+ CL-UNIFICATION.

+

+ * templates-hierarchy.lisp: Added LAMBDA-TEMPLATE.

+

+ * substitutions.lisp:

+ Added some functionality to extract all variables and/or all values

+ from an environment or a frame.

+

+ * match-block.lisp:

+ Added MATCHF (whose name may change) to simplify the

+ 'destructuring-bind'-like syntax and behavior of the matching

+ facilities.

+

+ * COPYING: Dates updated.

+

+ * unifier.lisp:

+ Major API change to 'unify'. It now accepts keywords. Old code

+ shouls not be affected, but new code is now more flexible. Look the

+ the STRING and (new) CHARACTER methods to see how this change is

+ affecting the code.

+

+ * variables.lisp: Some 'diff' unfathomable change happened.

+

+ * unification-package.lisp: Added exports of a few symbols.

+

+ * cl-unification.system, cl-unification.asd:

+ Fixed a few snags and added "lib-dependent" module.

+

+ * apply-substitution.lisp: Added some functionality and comments.

+

+2008-07-13 author <author@paniscia.pd.disco.unimib.it>

+

+ * ChangeLog: Changelog updated.

+

+ * ACKNOWLEDGEMENTS:

+ Added credits to a few people. Missing ones should bug the maintainer :)

+

+ * README: Copyright dates updated.

+

+ * unification.asd, unification.system: Cleaning up.

+ Committing in .

+

+ Removed Files:

+ unification.asd unification.system

+

+ * templates-hierarchy-saved.lisp: Clenaing up.

+ Committing in .

+

+ Removed Files:

+ templates-hierarchy-saved.lisp

+

+ * INSTALLATION: Instructions updated.

+

+ * COPYING: Copyright dates updated.

+

+ * test/unification-tests.lisp: Added file.

+

+ * substitutions.lisp, templates-hierarchy.lisp, unification-package.lisp, variables.lisp:

+ Some modification added. Exported symbols and reverted

+ reader macro #T to construct template instances at read time.

+ Added MAKE-LOAD-FORM method for templates which should fix problem with

+ SBCL.

+

+ Committing in .

+

+ Modified Files:

+ substitutions.lisp templates-hierarchy.lisp

+ unification-package.lisp variables.lisp

+

+ * cl-unification.system:

+ Added explicit :source-extension to accomodate Allegro CL.

+

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.

+(require "CL-PPCRE")

+

+ (multiple-value-bind (m-start m-end r-starts r-ends)

+ (cl-ppcre:scan (scanner re-t) s :start start :end end)

+ ;; Maybe SCAN-TO-STRINGS would be simpler to use...

- (multiple-value-bind (matched-p strings)

- (cl-ppcre:scan-to-strings (scanner re-t) s :start start :end end)

- (unless matched-p

+ (declare (type (integer 0 #.most-positive-fixnum) m-start m-end)

+ (type (vector (integer 0 #.most-positive-fixnum)) r-starts r-ends))

+ (unless (and (= start m-start) (= m-end end))

- (loop for r-string of-type string across strings

+ (loop for r-start across r-starts

+ for r-end across r-ends

+ for r-string of-type string = (subseq s r-start r-end)

+(in-package "UNIFY.TESTS")

+

+(defstruct s-root a)

+(defstruct (s-child (:include s-root)) b)

+

- (test '(#\f T) (ignore-errors (v? '?x (unify "asdfasdfasdf" #T(elt 3 ?x))))

- :multiple-values t

- :known-failure t

- :fail-info "ELT templates must be fixed.")

+ (test '(#\Space T) (ignore-errors (v? '?x (unify "This is a string!" #T(elt 4 ?x))))

+ :multiple-values t)

+

+ (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))

+ :multiple-values t)

+

+ (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(elt 2 ?x))))

+ :multiple-values t)

+

+ (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(aref 2 ?x))))

+ :multiple-values t)

+

+ (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(elt 2 ?x))))

+ :multiple-values t)

+

+ (test '(42 T) (v? '?x (unify #2a((0 1 42 3 4 5)) #T(aref (0 2) ?x)))

+ :multiple-values t)

+

+ (test '(42 T) (v? '?x (unify #T(aref (0 2) 42) #2a((0 1 ?x 3 4 5))))

+ :multiple-values t)

+

+ (test '(42 T) (v? '?x (unify #2a((0 1 ?x 3 4 5)) #T(aref (0 2) 42)))

+ :multiple-values t)

+

+ (test-error (unify #(0 1 42 3 4 5) #T(nth 2 ?x))

+ :condition-type 'unification-failure

+ :announce t)

- (test '(42 T) (ignore-errors (v? 'x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))

- :multiple-values t

- :known-failure t

- :fail-info "NTH templates must be fixed.")

+ (test '(foo (1) (2) (3)) (let ((result-env (unify '(0 1 #T(list foo _ &rest ?z) 42)

+ '(0 1 (?y bar (1) (2) (3)) 42)))

+ )

+ (cons (v? '?y result-env)

+ (v? '?z result-env)))

+ :test #'equal)

- (make-instance 'test1 :a '(1 2 3) :b "woot")))

+ (make-instance 'test1 :a '(1 2 3) :b "woot")))

+ :multiple-values t)

+

+ (test-error (unify #T(s-root s-root-a '(1 ?x 3 4))

+ (make-s-root :a '(1 2 3 4)))

+ :condition-type 'unification-failure

+ :announce t

+ ;; #T reader non evaluating sub forms.

+ )

+

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 4))

+ (make-s-root :a '(1 2 3 4))))

+ :multiple-values t)

+

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a (1 ?x 3 4))

+ (make-s-root :a '(1 2 3 4))))

+ :multiple-values t)

+

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 &rest))

+ (make-s-root :a '(1 2 3 4))))

+ :multiple-values t)

+

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a #(1 ?x 3 4))

+ (make-s-root :a #(1 2 3 4))))

+ :multiple-values t)

+

+ (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(vector 1 ?x 3 &rest))

+ (make-s-root :a #(1 2 3 4))))

- (otherwise "error-outer")))

+ (otherwise (error "error-outer"))))

- (test "error-outer" (nested-match-cases '(:a 42 :b 33)) :test 'string=)

+ (test-error (nested-match-cases '(:a 42 :b 33)) :announce t)

+

+ (test-error (nested-match-cases '(:a 42 :b (33 42))) :announce t)

+ (test '(42 43 44) (nested-match-cases '(:a 42 :b ((:d 42) (:c 43) (:c 44))))

+ :test #'equal)

Wed Apr 15 10:18:59 UTC 2009 mantoniotti

* Added LAMBDA-TEMPLATE.

-;;; -*- Mode: Lisp -*-

+;;;; -*- Mode: Lisp -*-

+

+;;;; templates-hierarchy.lisp --

+

+(defclass lambda-template (list-template expression-template) ())

+

+(defgeneric lambda-template-p (x)

+ (:method ((x lambda-template)) t)

+ (:method ((x t)) nil))

+

+

+

+(defmethod make-template ((kind (eql 'lambda)) (spec cons))

+ (make-instance 'lambda-template :spec spec))

+

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.

+(defun bindings-values (bindings) (mapcar #'cdr bindings))

+

+(defun bindings-keys (bindings) (mapcar #'car bindings))

+

+

-(defstruct frame

+(defstruct (frame (:constructor make-frame (&optional bindings)))

+(defun frame-variables (frame)

+ (mapcar 'binding-variable (frame-bindings frame)))

+

+

+(defun frame-values (frame)

+ (mapcar 'binding-value (frame-bindings frame)))

+

-(defun empty-environment-p (env &aux (env-frames (environment-frames env)))

+(defun empty-environment-p (env)

- (and (= 1 (list-length env-frames))

- (empty-frame-p (first env-frames))))

+ (let ((env-frames (environment-frames env)))

+ (declare (type list env-frames))

+ (and (= 1 (list-length env-frames))

+ (empty-frame-p (first env-frames)))))

-(defun extend-environment (var pat env)

+(defun extend-environment (var pat &optional (env (make-empty-environment)))

+(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 environment &optional boolean)

+ (values t boolean))

+ find-variable-value

+ v?))

+

- [_$_]

+

+

+(defun environment-variables (env)

+ (mapcan #'frame-variables (environment-frames env)))

+

+(defun environment-values (env)

+ (mapcan #'frame-values (environment-frames env)))

+

+

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.

+ (match-named nil)[_^M_][_$_]

+[_^M_][_$_]

+If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED[_^M_][_$_]

+is set up around the matching code.[_^M_][_$_]

- `(block nil[_^M_][_$_]

+ `(block ,match-named[_^M_][_$_]

+ (handler-case[_^M_][_$_]

+ (let* ((,env-var (unify ,template ,object ,substitution))[_^M_][_$_]

+ ,@(generate-var-bindings)[_^M_][_$_]

+ )[_^M_][_$_]

+ (declare (ignorable ,@(mapcar #'first[_^M_][_$_]

+ (generate-var-bindings))))[_^M_][_$_]

+ ,@forms)[_^M_][_$_]

+ [_^M_][_$_]

+ ;; Yes. The above is sligthly wasteful.[_^M_][_$_]

+[_^M_][_$_]

+ (unification-failure (uf)[_^M_][_$_]

+ (if ,errorp[_^M_][_$_]

+ (error uf)[_^M_][_$_]

+ ,error-value))[_^M_][_$_]

+ )))))[_^M_][_$_]

+[_^M_][_$_]

+[_^M_][_$_]

+(defmacro matchf ((template object[_^M_][_$_]

+ &key[_^M_][_$_]

+ (match-named nil)[_^M_][_$_]

+ (substitution '(make-empty-environment))[_^M_][_$_]

+ (errorp t)[_^M_][_$_]

+ (error-value nil))[_^M_][_$_]

+ &body forms)[_^M_][_$_]

+ "Sets up a lexical environment to evaluate FORMS after an unification.[_^M_][_$_]

+[_^M_][_$_]

+MATCHF unifies a TEMPLATE and an OBJECT and then sets up a lexical[_^M_][_$_]

+environment where the variables present in the template are bound[_^M_][_$_]

+lexically. Note that both variable names '?FOO' and 'FOO' are bound[_^M_][_$_]

+for convenience.[_^M_][_$_]

+[_^M_][_$_]

+MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will[_^M_][_$_]

+generate a template at read-time).[_^M_][_$_]

+[_^M_][_$_]

+The MATCHF form returns the values returned by the evaluation of the[_^M_][_$_]

+last of the FORMS.[_^M_][_$_]

+[_^M_][_$_]

+If ERRORP is non-NIL (the default) then the form raises a[_^M_][_$_]

+UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,[_^M_][_$_]

+whose default is NIL is returned. (Note that UNIFICATION-FAILUREs[_^M_][_$_]

+raising from the evaluation of FORMS will also be caught and handled[_^M_][_$_]

+according to ERRORP settings.)[_^M_][_$_]

+[_^M_][_$_]

+If MATCH-NAMED is not NIL, then a surrounding BLOCK named MATCH-NAMED[_^M_][_$_]

+is set up around the matching code.[_^M_][_$_]

+"[_^M_][_$_]

+ (let ((template-vars (collect-template-vars template))[_^M_][_$_]

+ (env-var (gensym "UNIFICATION-ENV-"))[_^M_][_$_]

+ (template (cond ((variablep template)[_^M_][_$_]

+ `',template) ; Logical variables are special-cased.[_^M_][_$_]

+ ((listp template) ; Same for lists.[_^M_][_$_]

+ (make-instance 'list-template[_^M_][_$_]

+ :spec (cons 'list template)))[_^M_][_$_]

+ ;`',template)[_^M_][_$_]

+ (t[_^M_][_$_]

+ template)))[_^M_][_$_]

+ )[_^M_][_$_]

+ ;; Logical variables and lists are special cased for convenience.[_^M_][_$_]

+ ;; Lists are especially inteded as abbreviation for destructuring.[_^M_][_$_]

+ (flet ((generate-var-bindings ()[_^M_][_$_]

+ (loop for v in template-vars[_^M_][_$_]

+ nconc (list `(,v (find-variable-value ',v[_^M_][_$_]

+ ,env-var))[_^M_][_$_]

+ `(,(clean-unify-var-name v) ,v))))[_^M_][_$_]

+ )[_^M_][_$_]

+ `(block ,match-named[_^M_][_$_]

- (make-empty-environment)))[_^M_][_$_]

+ (make-empty-environment))[_^M_][_$_]

+ (matching-named nil))[_^M_][_$_]

- `(block matching[_^M_][_$_]

+ `(block ,matching-named[_^M_][_$_]

-;;; When the construction of the inner MATCH clauses could be done[_^M_][_$_]

+;;; The construction of the inner MATCH clauses could be done[_^M_][_$_]

-(defmacro match-case ((object &key errorp default-substitution)[_^M_][_$_]

+(defmacro match-case ((object &key errorp default-substitution match-case-named)[_^M_][_$_]

- ,(generate-matchers (cdr clauses))))))))[_^M_][_$_]

- `(let ((,object-var ,object))[_^M_][_$_]

- ,(generate-matchers non-otherwise-clauses)))))[_^M_][_$_]

+ ,(generate-matchers (cdr clauses))))))))[_^M_][_$_]

+ `(block ,match-case-named[_^M_][_$_]

+ (let ((,object-var ,object))[_^M_][_$_]

+ ,(generate-matchers non-otherwise-clauses))))))[_^M_][_$_]

Wed Apr 15 10:14:59 UTC 2009 mantoniotti

* Dates updated.

-Copyright (c) 2004-2008 Marco Antoniotti[_^M_][_$_]

+Copyright (c) 2004-2009 Marco Antoniotti[_^M_][_$_]

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.

-(defgeneric unify (a b &optional env)

+(defgeneric unify (a b &optional env &key &allow-other-keys)

-(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)

-(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)

-(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)

-(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)

-(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-INSENSITIVE-P*, which defaults to NIL.

+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)

+ ((char-equal a b)

+ env)

+ (t

+ (error 'unification-failure

+ :format-control "Connot 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)

- (cond ((and *unify-string-case-insensitive-p* (string-equal a b))

+ (cond ((and case-sensitive (string= a b))

- ((string= a b)

+ ((string-equal 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)

-(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)

-(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)

-(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)

-(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)

-(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)

- :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."

-(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)

-(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)

-(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)

-(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)

-(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)

-(defmethod unify ((x template) (y template) &optional (env (make-empty-environment)))

+(defmethod unify ((x template) (y template)

+ &optional (env)

+ &key &allow-other-keys)

- :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."

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(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)

-(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)

-(defmethod unify ((a symbol) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b template)

+ &optional (env)

+ &key &allow-other-keys)

-(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)

-(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)

-(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)

-(defmethod unify ((a number) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a number) (b template)

+ &optional (env)

+ &key &allow-other-keys)

-(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)

-(defmethod unify ((a sequence) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a sequence) (b template)

+ &optional (env)

+ &key &allow-other-keys)

- :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."

-(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)

+#| 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))

+|#

+

+

-(defmethod unify ((a list) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a list) (b template)

+ &optional (env)

+ &key &allow-other-keys)

-(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)

-(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)

-(defmethod unify ((a vector) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a vector) (b template)

+ &optional (env)

+ &key &allow-other-keys)

-(defmethod unify ((a vector) (b vector-template) &optional (env (make-empty-environment)))

+(defmethod unify ((a vector) (b vector-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(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)

-(defmethod unify ((a array) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a array) (b template)

+ &optional (env)

+ &key &allow-other-keys)

- :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."

-(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)

- (apply #'array-row-major-index array (append indexes (list 0))))))

+ (apply #'array-row-major-index

+ array

+ (append indexes (list 0))))))

-(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)

-(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)

- :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."

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(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)

-(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)

- :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."

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- :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."

-(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)

-(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)

+ (declare (ignore subseq-kwd))

- (seq-template-kind (if (symbolp seq-type) seq-type (first seq-type))) ; Stupid FTTB.

+ (seq-template-kind (if (symbolp seq-type)

+ seq-type

+ (first seq-type))) ; Stupid FTTB.

+ (unify (subseq a from to)

+ (make-template seq-template-kind `(,seq-template-kind ,@spec))

+ env))))

+

+

+;;; LIST

+

+(defmethod unify ((a list) (b subseq-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (subseq-kwd from to &rest spec)

+ (template-spec b)

+ (declare (ignore subseq-kwd))

- (make-template seq-template-kind `(,seq-template-kind ,@spec))

- env))))

+ (make-template 'list `(list ,@spec))

+ env)))

+

+

+;;; VECTOR

+

+(defmethod unify ((a vector) (b subseq-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (subseq-kwd from to &rest spec)

+ (template-spec b)

+ (declare (ignore subseq-kwd))

+ (let ((seq-type (type-of a)))

+ (unify (subseq a from to)

+ (make-template seq-type `(,seq-type ,@spec))

+ env))))

-(defmethod unify ((b subseq-template) (a sequence) &optional (env (make-empty-environment)))

+(defmethod unify ((b subseq-template) (a sequence)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-;;; Expression template AREF methods.

+;;; Expression templates

-(defmethod unify ((a array) (b aref-template) &optional (env (make-empty-environment)))

+;;; AREF methods.

+

+(defmethod unify ((a array) (b aref-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+;;; 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)))

+ (ignore-errors (unify a b env)))

+

+

+(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)))

+

+

+(defmethod occurs-in-p ((var symbol) (pat character) env)

+ (declare (ignore env))

+ nil)

+

+

- (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."

- (type-of pat))

+ (type-of pat)

+ var)

Wed Apr 15 10:12:22 UTC 2009 mantoniotti

* Some 'diff' unfathomable change happened.

-(defun make-var-name (&optional (s (gensym)) (package *package*))

+(defun make-var-name (&optional (s (gensym "UNIFVAR-")) (package *package*))

Wed Apr 15 10:10:25 UTC 2009 mantoniotti

* Added exports of a few symbols.

+

+ "MATCHF"

- "MATCH-CASE"))

+ "MATCH-CASE")

+

+ (:export

+ "UNIFY*"

+ "UNIFY-EQUATIONS"

+ "UNIFY-EQUATIONS*")

+ )

Wed Apr 15 10:06:40 UTC 2009 mantoniotti

* Fixed a few snags and added "lib-dependent" module.

- (:file "apply-substitution")))

+ (:file "apply-substitution")

+ (:module "lib-dependent"

+ :depends-on ("templates-hierarchy" "unifier")

+ :components (

+ #+cl-ppcre

+ (:file "cl-ppcre-template")

+ ))))

- "apply-substitution"))

+ "apply-substitution"

+ (:module "lib-dependent"

+ :depends-on ("templates-hierarchy" "unifier")

+ :components (

+ #+cl-ppcre

+ (:file "cl-ppcre-template")

+ ))

+ ))

Wed Apr 15 10:05:58 UTC 2009 mantoniotti

* Added some functionality and comments.

-(defgeneric apply-substitution (substitution item))

+;;; apply-substitution --

+;;;

+;;; EXCLUDE-VARS are variables that will just pass through (a list for

+;;; the time being).

+(defgeneric apply-substitution (substitution item &optional exclude-vars))

-(defmethod apply-substitution ((substitution environment) (s symbol))

+

+(defmethod apply-substitution ((substitution environment) (s symbol)

+ &optional (exclude-vars ()))

+ (declare (type list exclude-vars))

- (multiple-value-bind (val foundp)

- (find-variable-value s substitution)

- (cond (foundp val)

- (t (warn "~S is a free variable in the current environment."

- s)

- s))))

+ (if (member s exclude-vars :test #'eq)

+ s

+ (multiple-value-bind (val foundp)

+ (find-variable-value s substitution)

+ (cond (foundp val)

+ (t (warn "~S is a free variable in the current environment."

+ s)

+ s))))

+ )

-(defmethod apply-substitution ((substitution environment) (l cons))

- (cons (apply-substitution substitution (first l))

- (apply-substitution substitution (rest l))))

+(defmethod apply-substitution ((substitution environment) (l cons)

+ &optional (exclude-vars ()))

+ (declare (type list exclude-vars))

+ (cons (apply-substitution substitution (first l) exclude-vars)

+ (apply-substitution substitution (rest l) exclude-vars)))

+

-(defmethod apply-substitution ((substitution environment) (l null))

+(defmethod apply-substitution ((substitution environment) (l null)

+ &optional exclude-vars)

+ (declare (ignore exclude-vars))

+

+;;; compose-substitions --

+;;; The definition is a direct translation of TPL's definition at page 318.

+;;; Usually these are done by directly composing and currying

+;;; functions in ML/Haskell derivatives, but that is just being "lazy".

+;;; The current definition may be too "eager", but the "correct"

+;;; semantics should be preserved.

+

+(defun compose-substitutions (env2 env1) ; note the order.

+ (declare (type environment env2 env1))

+

+ (loop for env1-frame in (environment-frames env1)

+ collect

+ (loop for (var . term) in (frame-bindings env1-frame)

+ collect (make-binding var (apply-substitution env2 term))

+ into result-bindings

+ finally (return (make-frame result-bindings)))

+ into frames

+ finally (return (make-environment :frames frames))))

+ [_$_]

+ [_$_]

+

+

+;;; ground-term --

+

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.

-2007-11-09 author <author@papadopoulou-2.ydras.offices.aueb.gr>

+2008-07-13 author <author@Macintosh.local>

+

+ * ACKNOWLEDGEMENTS:

+ Added credits to a few people. Missing ones should bug the maintainer :)

+

+ * README: Copyright dates updated.

+

+ * unification.asd, unification.system: Cleaning up.

+ Committing in .

+

+ Removed Files:

+ unification.asd unification.system

+

+ * templates-hierarchy-saved.lisp: Cleaning up.

+ Committing in .

+

+ Removed Files:

+ templates-hierarchy-saved.lisp

+

+ * INSTALLATION: Instructions updated.

+

+ * COPYING: Copyright dates updated.

+

+ * test/unification-tests.lisp: Added file.

+

+ * substitutions.lisp, templates-hierarchy.lisp, unification-package.lisp, variables.lisp:

+ Some modification added. Exported symbols and reverted

+ reader macro #T to construct template instances at read time.

+ Added MAKE-LOAD-FORM method for templates which should fix problem with

+ SBCL.

+

+ Committing in .

+

+ Modified Files:

+ substitutions.lisp templates-hierarchy.lisp

+ unification-package.lisp variables.lisp

+

+ * cl-unification.system:

+ Added explicit :source-extension to accomodate Allegro CL.

+

+2008-07-10 author <author@Macintosh.local>

+

+ * apply-substitution.lisp:

+ Removed EXPORT of APPLY-SUBSTITUTION as it is already in the DEFPACKAGE.

+

+2007-11-09 author <author@Macintosh.local>

+

+ * docs/html/index.html: Changed the position of the disclaimer.

+

+ * ChangeLog: ChangeLog updated.

+

+ * match-block.lisp:

+ Made several changes to improve MATCH-CASE (following a note from Ivan

+ Boldyrev from a long time ago), MATCHING and MATCH.

+

+ Else-clauses are now handled correctly (AFAICT).

+

+ Single variable templates in MATCH, MATCH-CASE and MATCHING clauses do

+ not need to be quoted.

+

+ MATCHING was generating one gensym'ed variable per clause without

+ creating an appropriate enclosing LET. This is now fixed.

+

+ * substitutions.lisp:

+ Changed the top comment and added a (:copier nil) option to the

+ ENVIRONMENT defstruct, as COPY-ENVIRONMENT is defined later in the

+ file.

+

+ * cl-unification.system, cl-unification.asd:

+ Added the new system building files with more meaningful names

+ w.r.t. the name of the library.

+

+ * unification.asd, unification.system:

+ Marked the two system building files as 'obsolete', before removing

+ them from the repository. The new files are prefixed by 'cl-'.

+

+2007-11-09 author <author@papadopoulou-2.ydras.offices.>

-2007-05-21 author <author@papadopoulou-2.ydras.offices.aueb.gr>

+2007-05-21 author <author@papadopoulou-2.ydras.offices.>

Sun Jul 13 13:33:48 UTC 2008 mantoniotti

* Added credits to a few people. Missing ones should bug the maintainer :)

-Many thanks to a lot of people are due.

+A lot of pleple deserved thanks for improving CL-UNIFICATION.

+Boldyrev, Ivan

+McManus, Russell

-

-

Sun Jul 13 13:30:28 UTC 2008 mantoniotti

* Copyright dates updated.

-Marco Antoniotti (c) 2004-2007

+Marco Antoniotti (c) 2004-2008

Sun Jul 13 13:28:48 UTC 2008 mantoniotti

* Cleaning up.

Cleaning up.

Committing in .

Removed Files:

unification.asd unification.system

-;;; -*- Mode: Lisp -*-

-

-;;; unification.asd --

-;;; ASDF system file.

-;;;

-;;; Note:

-;;; [20071109 MA]

-;;; This file is OBSOLETE. Use 'cl-unification.asd' instead.

-

-(asdf:defsystem cl-unification

- :author "Marco Antoniotti"

- :serial t

- :components ((:file "unification-package")

- (:file "variables")

- (:file "substitutions")

- (:file "lambda-list-parsing")

- (:file "templates-hierarchy")

- (:file "unifier")

- (:file "match-block")

- (:file "apply-substitution")))

-

-;;; end of file -- unification.asd --

-;;; -*- Mode: Lisp -*-

-

-;;; unification.system --

-;;; MK:DEFSYSTEM system file.

-;;;

-;;; Note:

-;;; [20071109 MA]

-;;; This file is OBSOLETE. Use 'cl-unification.system' instead.

-

-(mk:defsystem "UNIFICATION"

- :components ("unification-package"

- "variables"

- "substitutions"

- "lambda-list-parsing"

- "templates-hierarchy"

- "unifier"

- "match-block"

- "apply-substitution"))

- [_$_]

-;;; end of file -- unification.system --

Sun Jul 13 13:26:38 UTC 2008 mantoniotti

* Clenaing up.

Clenaing up.

Committing in .

Removed Files:

templates-hierarchy-saved.lisp

-;;; -*- 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 --

Sun Jul 13 13:20:01 UTC 2008 mantoniotti

* Instructions updated.

- (mk:load-system "unification")

+ (mk:load-system "CL-UNIFICATION")

- (mk:compile-system "unification")

+ (mk:compile-system "CL-UNIFICATION")

+Issuing

+

+ (asdf:oos 'asdf:load-op "CL-UNIFICATION")

+

+should make the library available in your environment.

+

- (asdf-install:install "unification")

+ (asdf-install:install "CL-UNIFICATION")

Sun Jul 13 13:17:29 UTC 2008 mantoniotti

* Copyright dates updated.

-Copyright (c) 2004-2007 Marco Antoniotti[_^M_][_$_]

+Copyright (c) 2004-2008 Marco Antoniotti[_^M_][_$_]

Sun Jul 13 13:14:56 UTC 2008 mantoniotti

* Added file.

-(in-package "UNIFY.TESTS")

-

-(defstruct s-root a)

-(defstruct (s-child (:include s-root)) b)

-

- (test '(#\Space T) (ignore-errors (v? '?x (unify "This is a string!" #T(elt 4 ?x))))

- :multiple-values t)

-

- (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))

- :multiple-values t)

-

- (test '(42 T) (ignore-errors (v? '?x (unify '(0 1 42 3 4 5) #T(elt 2 ?x))))

- :multiple-values t)

-

- (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(aref 2 ?x))))

- :multiple-values t)

-

- (test '(42 T) (ignore-errors (v? '?x (unify #(0 1 42 3 4 5) #T(elt 2 ?x))))

- :multiple-values t)

-

- (test '(42 T) (v? '?x (unify #2a((0 1 42 3 4 5)) #T(aref (0 2) ?x)))

- :multiple-values t)

-

- (test '(42 T) (v? '?x (unify #T(aref (0 2) 42) #2a((0 1 ?x 3 4 5))))

- :multiple-values t)

-

- (test '(42 T) (v? '?x (unify #2a((0 1 ?x 3 4 5)) #T(aref (0 2) 42)))

- :multiple-values t)

-

- (test-error (unify #(0 1 42 3 4 5) #T(nth 2 ?x))

- :condition-type 'unification-failure

- :announce t)

+ (test '(#\f T) (ignore-errors (v? '?x (unify "asdfasdfasdf" #T(elt 3 ?x))))

+ :multiple-values t

+ :known-failure t

+ :fail-info "ELT templates must be fixed.")

- (test '(foo (1) (2) (3)) (let ((result-env (unify '(0 1 #T(list foo _ &rest ?z) 42)

- '(0 1 (?y bar (1) (2) (3)) 42)))

- )

- (cons (v? '?y result-env)

- (v? '?z result-env)))

- :test #'equal)

+ (test '(42 T) (ignore-errors (v? 'x (unify '(0 1 42 3 4 5) #T(nth 2 ?x))))

+ :multiple-values t

+ :known-failure t

+ :fail-info "NTH templates must be fixed.")

- (make-instance 'test1 :a '(1 2 3) :b "woot")))

- :multiple-values t)

-

- (test-error (unify #T(s-root s-root-a '(1 ?x 3 4))

- (make-s-root :a '(1 2 3 4)))

- :condition-type 'unification-failure

- :announce t

- ;; #T reader non evaluating sub forms.

- )

-

- (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 4))

- (make-s-root :a '(1 2 3 4))))

- :multiple-values t)

-

- (test '(2 T) (v? '?x (unify #T(s-root s-root-a (1 ?x 3 4))

- (make-s-root :a '(1 2 3 4))))

- :multiple-values t)

-

- (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(list 1 ?x 3 &rest))

- (make-s-root :a '(1 2 3 4))))

- :multiple-values t)

-

- (test '(2 T) (v? '?x (unify #T(s-root s-root-a #(1 ?x 3 4))

- (make-s-root :a #(1 2 3 4))))

- :multiple-values t)

-

- (test '(2 T) (v? '?x (unify #T(s-root s-root-a #T(vector 1 ?x 3 &rest))

- (make-s-root :a #(1 2 3 4))))

+ (make-instance 'test1 :a '(1 2 3) :b "woot")))

- (otherwise (error "error-outer"))))

+ (otherwise "error-outer")))

- (test-error (nested-match-cases '(:a 42 :b 33)) :announce t)

-

- (test-error (nested-match-cases '(:a 42 :b (33 42))) :announce t)

+ (test "error-outer" (nested-match-cases '(:a 42 :b 33)) :test 'string=)

- (test '(42 43 44) (nested-match-cases '(:a 42 :b ((:d 42) (:c 43) (:c 44))))

- :test #'equal)

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

+(defun v? (s env &optional (plain-symbol-p nil))

+ (find-variable-value (if plain-symbol-p

+ (make-var-name s)

+ s)

+ env))

+ [_$_]

+

+

+

-#||

+;;; 20080711 MA:

+;;; Reverted to the old version with MAKE-LOAD-FORM added. Template

+;;; objects are created at read-time.

+

-||#

+(defmethod make-load-form ((x template) &optional env)

+ (make-load-form-saving-slots x :environment env))

-;;; New version with more 'macro-like' behavior. The previous version

+

+#||

+;;; Version with more 'macro-like' behavior. The previous version

+;;;

+;;; 20080713 MA

+;;; Removed because it was not working well with nested templates.

+;;; Reverted to the original one plus MAKE-LOAD-FORM.

-

+||#

- (set-dispatch-macro-character #\# #\T #'|sharp-T-reader|))

+ (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)))

+

+||#

+ [_$_]

+

-

-;;; Implementation.

+;;;;===========================================================================

+;;;; Implementation.

+

+

+ "V?"

+

- "APPLY-SUBSTITUTION")

+ "APPLY-SUBSTITUTION"

+

+ "UNIFICATION-FAILURE"

+ "UNIFICATION-VARIABLE-UNBOUND"

+ )

+

+ (:export

+ "ENVIRONMENT"

+ "ENVIRONMENT-P")

+

+

+(defun make-var-name (&optional (s (gensym)) (package *package*))

+ (intern (concatenate 'string "?" (symbol-name s)) package))

+

+

Sun Jul 13 12:51:14 UTC 2008 mantoniotti

* Added explicit :source-extension to accomodate Allegro CL.

- :components ("unification-package"

- "variables"

- "substitutions"

- "lambda-list-parsing"

- "templates-hierarchy"

- "unifier"

- "match-block"

- "apply-substitution"))

+ :source-extension "lisp"

+ :components ("unification-package"

+ "variables"

+ "substitutions"

+ "lambda-list-parsing"

+ "templates-hierarchy"

+ "unifier"

+ "match-block"

+ "apply-substitution"))

Thu Jul 10 17:39:16 UTC 2008 mantoniotti

* Removed EXPORT of APPLY-SUBSTITUTION as it is already in the DEFPACKAGE.

- (t (warn "~S is a free variable in the current environment." s)

+ (t (warn "~S is a free variable in the current environment."

+ s)

-(export '(apply-substitution))

-

-

Fri Nov 9 13:56:40 UTC 2007 mantoniotti

* Changed the position of the disclaimer.

-

- <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>

-

+

+

+ <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>

+

+ <li><strong>2007-11-09</strong><br>

+ Updated.

Fri Nov 9 13:47:00 UTC 2007 mantoniotti

* ChangeLog updated.

+2007-11-09 author <author@papadopoulou-2.ydras.offices.aueb.gr>

+

+ * match-block.lisp:

+ Made several changes to improve MATCH-CASE (following a note from Ivan

+ Boldyrev from a long time ago), MATCHING and MATCH.

+

+ Else-clauses are now handled correctly (AFAICT).

+

+ Single variable templates in MATCH, MATCH-CASE and MATCHING clauses do

+ not need to be quoted.

+

+ MATCHING was generating one gensym'ed variable per clause without

+ creating an appropriate enclosing LET. This is now fixed.

+

+ * substitutions.lisp:

+ Changed the top comment and added a (:copier nil) option to the

+ ENVIRONMENT defstruct, as COPY-ENVIRONMENT is defined later in the

+ file.

+

+ * cl-unification.system, cl-unification.asd:

+ Added the new system building files with more meaningful names

+ w.r.t. the name of the library.

+

+ * unification.asd, unification.system:

+ Marked the two system building files as 'obsolete', before removing

+ them from the repository. The new files are prefixed by 'cl-'.

+

+2007-05-21 author <author@papadopoulou-2.ydras.offices.aueb.gr>

+

+ * ChangeLog: ChangeLog updated.

+

+ * README, ACKNOWLEDGEMENTS, COPYING, INSTALLATION:

+ Updated copyrights dates and changed a few instructions in the

+ INSTALLATION file.

+

+ * docs/html/index.html: Updated copyrights dates.

+

+ * ChangeLog: ChangeLog updated.

+

+ * unification-package.lisp, unification.asd, apply-substitution.lisp, match-block.lisp, substitutions.lisp:

+ See previous message.

+

+ * unification.system:

+ 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.

+

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.

-;;; -*- Mode: Lisp -*-[_^M_][_$_]

+;;;; -*- Mode: Lisp -*-[_^M_][_$_]

+[_^M_][_$_]

+;;;; match-block.lisp --[_^M_][_$_]

+;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.[_^M_][_$_]

- "Sets up a lexical environment to evaluate FORMS after a unification operation.[_^M_][_$_]

+ "Sets up a lexical environment to evaluate FORMS after an unification.[_^M_][_$_]

+[_^M_][_$_]

+ (template (if (variablep template)[_^M_][_$_]

+ `',template ; Logical variables are special-cased.[_^M_][_$_]

+ template))[_^M_][_$_]

- nconc (list `(,v (find-variable-value ',v ,env-var))[_^M_][_$_]

+ nconc (list `(,v (find-variable-value ',v[_^M_][_$_]

+ ,env-var))[_^M_][_$_]

- (declare (ignorable ,@(mapcar #'first (generate-var-bindings))))[_^M_][_$_]

+ (declare (ignorable ,@(mapcar #'first[_^M_][_$_]

+ (generate-var-bindings))))[_^M_][_$_]

- (default-substitution (make-empty-environment)))[_^M_][_$_]

+ (default-substitution[_^M_][_$_]

+ (make-empty-environment)))[_^M_][_$_]

+[_^M_][_$_]

- (let ((template-vars (collect-template-vars template)))[_^M_][_$_]

+ (let ((template-vars (collect-template-vars template))[_^M_][_$_]

+ (template (if (variablep template)[_^M_][_$_]

+ `',template ; Logical variables are[_^M_][_$_]

+ ; special-cased.[_^M_][_$_]

+ template)) [_^M_][_$_]

+ )[_^M_][_$_]

- (ignore-errors (unify ',template[_^M_][_$_]

+ (ignore-errors (unify ,template[_^M_][_$_]

- (let* ((default-clause (or (find t match-clauses :key #'first)[_^M_][_$_]

- (find 'otherwise match-clauses :key #'first)))[_^M_][_$_]

- (match-clauses (delete default-clause match-clauses)) ; EQL test suffices.[_^M_][_$_]

+ (let* ((default-clause (or (find t match-clauses[_^M_][_$_]

+ :key #'first)[_^M_][_$_]

+ (find 'otherwise match-clauses[_^M_][_$_]

+ :key #'first)))[_^M_][_$_]

+ (match-clauses (delete default-clause match-clauses)) ; EQL[_^M_][_$_]

+ ; test[_^M_][_$_]

+ ; suffices.[_^M_][_$_]

+ (match-clauses-env-vars (mapcar (lambda (mc)[_^M_][_$_]

+ (declare (ignore mc))[_^M_][_$_]

+ (gensym "UNIFICATION-ENV-")[_^M_][_$_]

+ )[_^M_][_$_]

+ match-clauses))[_^M_][_$_]

- `(block matching[_^M_][_$_]

- (cond ,@(mapcar (lambda (match-clause match-clause-env-var)[_^M_][_$_]

- (build-match-clause match-clause match-clause-env-var))[_^M_][_$_]

- match-clauses[_^M_][_$_]

- (mapcar (lambda (mc)[_^M_][_$_]

- (declare (ignore mc))[_^M_][_$_]

- (gensym "UNIFICATION-ENV-")[_^M_][_$_]

- )[_^M_][_$_]

- match-clauses))[_^M_][_$_]

- (,errorp[_^M_][_$_]

- (error 'unification-non-exhaustive[_^M_][_$_]

- :format-control "Non exhaustive matching."))[_^M_][_$_]

- ,@(when default-clause (list default-clause)))))[_^M_][_$_]

- ))[_^M_][_$_]

+ `(block matching[_^M_][_$_]

+ (let ,match-clauses-env-vars[_^M_][_$_]

+ (declare (dynamic-extent ,@match-clauses-env-vars))[_^M_][_$_]

+ (cond ,@(mapcar (lambda (match-clause match-clause-env-var)[_^M_][_$_]

+ (build-match-clause match-clause[_^M_][_$_]

+ match-clause-env-var))[_^M_][_$_]

+ match-clauses[_^M_][_$_]

+ match-clauses-env-vars)[_^M_][_$_]

+ (,errorp[_^M_][_$_]

+ (error 'unification-non-exhaustive[_^M_][_$_]

+ :format-control "Non exhaustive matching."))[_^M_][_$_]

+ ,@(when default-clause (list default-clause))))))[_^M_][_$_]

+ ))[_^M_][_$_]

+;;;[_^M_][_$_]

+;;; Notes:[_^M_][_$_]

+;;;[_^M_][_$_]

+;;; [MA 20071109][_^M_][_$_]

+;;; When the construction of the inner MATCH clauses could be done[_^M_][_$_]

+;;; more intelligently by supplying :ERRORP NIL, thus avoiding the[_^M_][_$_]

+;;; HANDLER-CASEs, which are quite expensive. Any takers?[_^M_][_$_]

-(defmacro match-case ((object &key errorp default-substitution) &rest clauses)[_^M_][_$_]

+(defmacro match-case ((object &key errorp default-substitution)[_^M_][_$_]

+ &rest clauses)[_^M_][_$_]

+[_^M_][_$_]

- `(error 'unification-non-exhaustive[_^M_][_$_]

- :format-control "Non exhaustive matching."))))[_^M_][_$_]

+ `(t (error 'unification-non-exhaustive[_^M_][_$_]

+ :format-control "Non exhaustive matching.")))))[_^M_][_$_]

+;;;;---------------------------------------------------------------------------[_^M_][_$_]

+;;;; Testing.[_^M_][_$_]

+[_^M_][_$_]

+#| Tests[_^M_][_$_]

+[_^M_][_$_]

+(let ((n 42))[_^M_][_$_]

+ (matching ()[_^M_][_$_]

+ ((0 n) 1)[_^M_][_$_]

+ ((?x n) (* x (1- x)))))[_^M_][_$_]

+[_^M_][_$_]

+[_^M_][_$_]

+(let ((n 42))[_^M_][_$_]

+ (match-case (n)[_^M_][_$_]

+ (0 1)[_^M_][_$_]

+ (?x (* x (1- x)))))[_^M_][_$_]

+[_^M_][_$_]

+[_^M_][_$_]

+(let ((n 42))[_^M_][_$_]

+ (match-case (n)[_^M_][_$_]

+ (0 1)[_^M_][_$_]

+ (otherwise (* n (1- n)))))[_^M_][_$_]

+[_^M_][_$_]

+(defun fatt (x)[_^M_][_$_]

+ (match-case (x :errorp t)[_^M_][_$_]

+ (0 1)[_^M_][_$_]

+ (#T(number ?n) (* ?n (fatt (1- n))))[_^M_][_$_]

+ ))[_^M_][_$_]

+[_^M_][_$_]

+|#[_^M_][_$_]

-;;; end of file -- math-blocks.lisp --[_^M_][_$_]

+;;;; end of file -- math-blocks.lisp --[_^M_][_$_]

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.

-;;; -*- 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.

-(defstruct (environment (:print-object print-environment))

+(defstruct (environment (:print-object print-environment)

+ (:copier nil))

-;;; end of file -- substitutions.lisp --

+;;;; end of file -- substitutions.lisp --

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.

-;;;;===========================================================================

-;;;; Simple stuff that should be built in ASDF.

-

-(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")

-

-

-(asdf:defsystem :cl-unification

- :author "Marco Antoniotti"

- :serial t

- :components ((:file "unification-package")

- (:file "variables")

- (:file "substitutions")

- (:file "lambda-list-parsing")

- (:file "templates-hierarchy")

- (:file "unifier")

- (:file "match-block")

- (:file "apply-substitution")

- #+asdf-with-optional-dependencies

- (:module "lib-dependent"

- :pathname "lib-dependent"

- :depends-on ("templates-hierarchy" "unifier")

- :components ((:file "cl-ppcre-template"

- :depends-on (cl-ppcre))

- ))

- #-asdf-with-optional-dependencies

- (asdf-system-definition-file

- "cl-unification-lib")

- ))

+(asdf:defsystem cl-unification

+ :author "Marco Antoniotti"

+ :serial t

+ :components ((:file "unification-package")

+ (:file "variables")

+ (:file "substitutions")

+ (:file "lambda-list-parsing")

+ (:file "templates-hierarchy")

+ (:file "unifier")

+ (:file "match-block")

+ (:file "apply-substitution")))

- :source-extension "lisp"

- "apply-substitution"

- (:module "lib-dependent"

- :depends-on ("templates-hierarchy" "unifier")

- :components ((:subsystem "cl-ppcre-template"

- :non-required-p t

- )

- ))

- ))

+ "apply-substitution"))

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-'.

+;;;

+;;; Note:

+;;; [20071109 MA]

+;;; This file is OBSOLETE. Use 'cl-unification.asd' instead.

-(asdf:defsystem unification

+(asdf:defsystem cl-unification

+;;; unification.system --

+;;; MK:DEFSYSTEM system file.

+;;;

+;;; Note:

+;;; [20071109 MA]

+;;; This file is OBSOLETE. Use 'cl-unification.system' instead.

+

Mon May 21 17:12:58 UTC 2007 mantoniotti

* ChangeLog updated.

+2007-05-21 author <author@Paniscia-di-Marco-Antoniotti.local>

+

+ * README, ACKNOWLEDGEMENTS, COPYING, INSTALLATION:

+ Updated copyrights dates and changed a few instructions in the

+ INSTALLATION file.

+

+ * docs/html/index.html: Updated copyrights dates.

+

+ * ChangeLog: ChangeLog updated.

+

+ * unification-package.lisp, unification.asd, apply-substitution.lisp, match-block.lisp, substitutions.lisp:

+ See previous message.

+

+ * unification.system:

+ 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.

+

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.

+Korablin, Vladimir V.

+Leuner, John

+

+

-Copyright (c) 2004-2005 Marco Antoniotti[_^M_][_$_]

+Copyright (c) 2004-2007 Marco Antoniotti[_^M_][_$_]

+There is also an ASDF system definition for those who use this system.

+

-Marco Antoniotti 2004-2005

+Marco Antoniotti (c) 2004-2007

Mon May 21 17:10:26 UTC 2007 mantoniotti

* Updated copyrights dates.

- &copy; 2003-2004, Marco Antoniotti, all rights reserved.

+ &copy; 2004-2007, Marco Antoniotti, all rights reserved.

Mon May 21 16:55:57 UTC 2007 mantoniotti

* ChangeLog updated.

+2007-05-21 author <author@paniscia.disco.unimib.it>

+

+ * unification.system:

+ 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.

+

+2006-07-19 author <author@paniscia.disco.unimib.it>

+

+ * templates-hierarchy.lisp, unifier.lisp:

+ 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

+

+ * unification-package.lisp: Added missing export.

+

+2005-10-25 author <author@paniscia.disco.unimib.it>

+

+ * unifier.lisp: 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.

+

+ * match-block.lisp:

+ Fixed problem with checking the presence of T and OTHERWISE clauses in

+ MATCHING.

+

+2005-07-25 author <author@paniscia.disco.unimib.it>

+

+ * docs/html/downloads.html: Minor cleanup.

+

+2005-05-20 author <author@paniscia.disco.unimib.it>

+

+ * docs/html/links.html: Fixed typos.

+

+ * docs/html/nil-template-class.html: Fixed bug in documentation.

+

+ * docs/html/links.html: Page updated.

+

+ * docs/html/unification-dictionary.html: Incremental change to page.

+

+ * docs/html/number-template-class.html: Fixed a documentation bug.

+ Thanks to Norman Werner for spotting it.

+

+ * docs/html/index.html: Added link to "Mailing Lists" page.

+

+ * docs/html/mailing-lists.html: File added.

+

+ * unifier.lisp:

+ 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.

+

+2005-05-19 author <author@paniscia.disco.unimib.it>

+

+ * README: Year updated.

+

+ * ACKNOWLEDGEMENTS: File added.

+

+ * ChangeLog: ChangeLog updated.

+

+ * COPYING: Updated copyright notice.

+

+ * docs/html/downloads.html, docs/html/index.html:

+ Changed the DISCLAIMER parts in the files, in order to clarify the licensing

+ of the code.

+

Mon May 21 12:33:05 UTC 2007 mantoniotti

* See previous message.

-;;; apply-substitution --

-;;;

-;;; EXCLUDE-VARS are variables that will just pass through (a list for

-;;; the time being).

+(defgeneric apply-substitution (substitution item))

-(defgeneric apply-substitution (substitution item &optional exclude-vars))

-

-(defmethod apply-substitution ((s environment) (n number) &optional exclude-vars)

- (declare (ignore exclude-vars))

- n)

-

-

-(defmethod apply-substitution ((substitution environment) (s symbol)

- &optional (exclude-vars ()))

- (declare (type list exclude-vars))

+(defmethod apply-substitution ((substitution environment) (s symbol))

- (if (member s exclude-vars :test #'eq)

- s

- (multiple-value-bind (val foundp)

- (find-variable-value s substitution)

- (cond (foundp (apply-substitution substitution val exclude-vars))

- (t (warn "~S is a free variable in the current environment."

- s)

- s))))

- )

+ (multiple-value-bind (val foundp)

+ (find-variable-value s substitution)

+ (cond (foundp val)

+ (t (warn "~S is a free variable in the current environment." s)

+ s))))

-(defmethod apply-substitution ((substitution environment) (l cons)

- &optional (exclude-vars ()))

- (declare (type list exclude-vars))

- (cons (apply-substitution substitution (first l) exclude-vars)

- (apply-substitution substitution (rest l) exclude-vars)))

-

+(defmethod apply-substitution ((substitution environment) (l cons))

+ (cons (apply-substitution substitution (first l))

+ (apply-substitution substitution (rest l))))

-(defmethod apply-substitution ((substitution environment) (l null)

- &optional exclude-vars)

- (declare (ignore exclude-vars))

+(defmethod apply-substitution ((substitution environment) (l null))

+(export '(apply-substitution))

-;;; compose-substitions --

-;;; The definition is a direct translation of TPL's definition at page 318.

-;;; Usually these are done by directly composing and currying

-;;; functions in ML/Haskell derivatives, but that is just being "lazy".

-;;; The current definition may be too "eager", but the "correct"

-;;; semantics should be preserved.

-

-(defun compose-substitutions (env2 env1) ; note the order.

- (declare (type environment env2 env1))

-

- (loop for env1-frame in (environment-frames env1)

- collect

- (loop for (var . term) in (frame-bindings env1-frame)

- collect (make-binding var (apply-substitution env2 term))

- into result-bindings

- finally (return (make-frame result-bindings)))

- into frames

- finally (return (make-environment :frames frames))))

- [_$_]

- [_$_]

-

-

-;;; ground-term --

- (substitution (make-empty-environment))[_^M_][_$_]

+ (substitution '(make-empty-environment))[_^M_][_$_]

- (let* ((,env-var (unify ',template ,object ,substitution))[_^M_][_$_]

+ (let* ((,env-var (unify ,template ,object ,substitution))[_^M_][_$_]

- (signal uf)[_^M_][_$_]

+ (error uf)[_^M_][_$_]

-The full syntax of MATCHING is[_^M_][_$_]

+The full syntax of MATCH-CASE is[_^M_][_$_]

-The values returned by the MATCHING form are those of the last form in[_^M_][_$_]

+The values returned by the MATCH-CASE form are those of the last form in[_^M_][_$_]

- otherwise-clause[_^M_][_$_]

+ `(progn ,@(rest otherwise-clause))[_^M_][_$_]

+(defun (setf binding-variable) (v b)

+ (declare (type binding b))

+ (setf (car b) v))

+

+

+(defun (setf binding-value) (v b)

+ (declare (type binding b))

+ (setf (cdr b) v))

+

+

+

- "MAKE-EMPTY-ENVIRONMENT")

+ "MAKE-EMPTY-ENVIRONMENT"

+ "APPLY-SUBSTITUTION")

- (:file "match-block")))

+ (:file "match-block")

+ (:file "apply-substitution")))

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.

- "match-block"))

+ "match-block"

+ "apply-substitution"))

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

-(defun |#T-reader| (stream subchar arg)

+#||

+(defun |sharp-T-reader| (stream subchar arg)

+||#

+

+

+;;; New 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.

+

+(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)))

+ ))

- (set-dispatch-macro-character #\# #\T #'|#T-reader|))

+ (set-dispatch-macro-character #\# #\T #'|sharp-T-reader|))

+ (declare (ignore env))

-(defmethod unify ((x null) (nt nil-template) &optional (env (make-empty-environment)))

+(defmethod unify ((x null) (y null)

+ &optional (env (make-empty-environment)))

+ env)

+

+

+(defmethod unify ((x null) (nt nil-template)

+ &optional (env (make-empty-environment)))

-(defmethod unify ((nt nil-template) (x null) &optional (env (make-empty-environment)))

+(defmethod unify ((nt nil-template) (x null)

+ &optional (env (make-empty-environment)))

-(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)))

+ (declare (ignore env))

+ (declare (ignore env))

+ (declare (ignore env))

- (declare (ignore array-kwd))

+ (declare (ignore array-kwd type-spec))

+ (declare (ignore env))

-#| Old version with heavy syntax

+#|| Old version with heavy syntax

-|#

+||#

+ (declare (ignore env))

- (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))))

-#|

+#||

-|#

+||#

+

+

+

+(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)

+

+

Wed Jul 19 20:28:49 UTC 2006 mantoniotti

* Added missing export.

- "MATCHING"))

+ "MATCHING"

+ "MATCH-CASE"))

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.

- (env (unify (subseq a 0 (list-length vars)) vars env))

+ (env (unify (subseq a 0 (min ll (list-length vars)))

+ vars

+ env))

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.

- nconc (list `(,v (find-variable-value ',v ,clause-var))[_^M_][_$_]

+ nconc (list `(,v (find-variable-value[_^M_][_$_]

+ ',v[_^M_][_$_]

+ ,clause-var))[_^M_][_$_]

- (ignore-errors (unify ',template ,object ,substitution)))[_^M_][_$_]

+ (ignore-errors (unify ',template[_^M_][_$_]

+ ,object[_^M_][_$_]

+ ,substitution)))[_^M_][_$_]

- (%%match%% match-env-var template object forms '(make-empty-environment))))[_^M_][_$_]

+ (%%match%% match-env-var[_^M_][_$_]

+ template[_^M_][_$_]

+ object[_^M_][_$_]

+ forms[_^M_][_$_]

+ '(make-empty-environment))))[_^M_][_$_]

- (when (or (> 1 (count t match-clauses :key #'first))[_^M_][_$_]

- (> 1 (count 'otherwise match-clauses :key #'first)))[_^M_][_$_]

+ (when (or (and (find t match-clauses :key #'first)[_^M_][_$_]

+ (find 'otherwise match-clauses :key #'first))[_^M_][_$_]

+ (> (count t match-clauses :key #'first) 1)[_^M_][_$_]

+ (> (count 'otherwise match-clauses :key #'first) 1))[_^M_][_$_]