Two strings unify only is they are "equal", under the following
- condition. If the variable *UNIFY-STRING-CASE-INSENSITIVE-P* is NIL
+ condition. If the variable *UNIFY-STRING-CASE-SENSITIVE-P* is T
(the default) then the two strings s1 and s2 are
compared using STRING=, otherwise they are compared using STRING-EQUAL.
The value of *UNIFY-STRING-CASE-INSENSITIVE-P* controls the
+
The value of *UNIFY-STRING-CASE-SENSITIVE-P* controls the
behavior of the UNIFY method with signature (stringstring).
- If NIL (the default), the method will use STRING= to test for
+ If T (the default), the method will use STRING= to test for
equality of the two strings. Otherwise, the UNIFY method will use STRING-EQUAL.
Affected By:
diff -rN -u old-cl-unification-1/lambda-list-parsing.lisp new-cl-unification-1/lambda-list-parsing.lisp
--- old-cl-unification-1/lambda-list-parsing.lisp 2013-07-25 02:31:29.000000000 +0000
+++ new-cl-unification-1/lambda-list-parsing.lisp 2013-07-25 02:31:29.000000000 +0000
@@ -2,6 +2,8 @@
;;; lambda-list-parsing.lisp --
+;;;; See file COPYING for copyright licensing information.
+
(in-package "UNIFY")
@@ -49,7 +51,7 @@
)
;;; The next function is really implementation-dependent, give the
-;;; definition of LAMBDA-LIST-KEYWORDS
+;;; definition of LAMBDA-LIST-KEYWORDS.
(define-condition lambda-list-parsing-error (program-error)
@@ -90,7 +92,7 @@
(&aux (parse-auxiliary-arguments (rest lambda-list)))
(&rest (parse-rest-arguments (rest lambda-list)))
(otherwise
- (warn "Keyword ~A is implementation dependent.~@
+ (warn "Keyword ~A is implementation dependent.~@
The parsing may not work properly."
head)
(skip-until-next-lambda-list-keyword (rest lambda-list))
@@ -112,7 +114,7 @@
(&aux (parse-auxiliary-arguments (rest lambda-list)))
(&rest (parse-rest-arguments (rest lambda-list)))
(otherwise
- (warn "Keyword ~A is implementation dependent.~@
+ (warn "Keyword ~A is implementation dependent.~@
The parsing may not work properly."
head)
(skip-until-next-lambda-list-keyword (rest lambda-list))
@@ -139,7 +141,7 @@
(error 'lambda-list-parsing-error :item head))
(skip-until-next-lambda-list-keyword (rest lambda-list)))
(otherwise
- (warn "Keyword ~A is implementation dependent.~@
+ (warn "Keyword ~A is implementation dependent.~@
The parsing may not work properly."
head)
(skip-until-next-lambda-list-keyword (rest lambda-list))
@@ -165,7 +167,7 @@
(&aux (parse-auxiliary-arguments (rest lambda-list)))
(&rest (error 'lambda-list-parsing-error :item head))
(otherwise
- (warn "Keyword ~A is implementation dependent.~@
+ (warn "Keyword ~A is implementation dependent.~@
The parsing may not work properly."
head)
(skip-until-next-lambda-list-keyword (rest lambda-list))
@@ -187,7 +189,7 @@
(&aux (error 'lambda-list-parsing-error :item head))
(&rest (error 'lambda-list-parsing-error :item head))
(otherwise
- (warn "Keyword ~A is implementation dependent.~@
+ (warn "Keyword ~A is implementation dependent.~@
The parsing may not work properly."
head)
(skip-until-next-lambda-list-keyword (rest lambda-list))
@@ -210,7 +212,7 @@
(&aux (parse-auxiliary-arguments (rest lambda-list)))
(&rest (parse-rest-arguments (rest lambda-list)))
(otherwise
- (warn "Keyword ~A is implementation dependent.~@
+ (warn "Keyword ~A is implementation dependent.~@
The parsing may not work properly."
head)
(skip-until-next-lambda-list-keyword (rest lambda-list))
@@ -277,7 +279,7 @@
(symbol (make-key-lambda-var-info :name var
:type init-value-type
:default-value init-value))
-
+
(cons (destructuring-bind (kwd var)
var
(etypecase var
diff -rN -u old-cl-unification-1/lib-dependent/cl-ppcre-template.lisp new-cl-unification-1/lib-dependent/cl-ppcre-template.lisp
--- old-cl-unification-1/lib-dependent/cl-ppcre-template.lisp 2013-07-25 02:31:29.000000000 +0000
+++ new-cl-unification-1/lib-dependent/cl-ppcre-template.lisp 2013-07-25 02:31:29.000000000 +0000
@@ -144,6 +144,6 @@
&optional (env (make-empty-environment))
&key (start 0) end &allow-other-keys)
(unify re-t s env :start start :end end))
-
+
;;;; end of file -- cl-ppcre-template.lisp --
diff -rN -u old-cl-unification-1/match-block.lisp new-cl-unification-1/match-block.lisp
--- old-cl-unification-1/match-block.lisp 2013-07-25 02:31:29.000000000 +0000
+++ new-cl-unification-1/match-block.lisp 2013-07-25 02:31:29.000000000 +0000
@@ -3,6 +3,8 @@
;;;; match-block.lisp --
;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.
+;;;; See file COPYING for copyright licensing information.
+
(in-package "UNIFY")
(defun clean-unify-var-name (v)
diff -rN -u old-cl-unification-1/substitutions.lisp new-cl-unification-1/substitutions.lisp
--- old-cl-unification-1/substitutions.lisp 2013-07-25 02:31:29.000000000 +0000
+++ new-cl-unification-1/substitutions.lisp 2013-07-25 02:31:29.000000000 +0000
@@ -4,6 +4,8 @@
;;;; General CL structures unifier.
;;;; Substitution definitions. Mostly a rehash of the usual SICP stuff.
+;;;; See file COPYING for copyright licensing information.
+
(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
;;;---------------------------------------------------------------------------
@@ -113,10 +115,23 @@
(make-environment :frames (list (make-frame))))
(defun copy-environment (env)
+ (declare (type environment env))
(make-environment :frames (copy-list (environment-frames env))))
-(defun make-shared-environment (env)
- (make-environment :frames (environment-frames env)))
+(defun make-shared-environment (env &optional (pushp nil))
+ (declare (type environment env))
+ (make-environment :frames (if pushp
+ (cons (make-frame) (environment-frames env))
+ (environment-frames env))))
+
+(defun push-frame (env)
+ (declare (type environment env))
+ (push (make-frame) (environment-frames env)))
+
+(defun pop-frame (env)
+ (declare (type environment env))
+ (pop (environment-frames env)))
+
(defun make-expanded-environment (base-env)
(make-environment :frames (cons (make-frame) (environment-frames base-env))))
@@ -187,6 +202,25 @@
(mapcan #'frame-values (environment-frames env)))
+;;;---------------------------------------------------------------------------
+;;; Simple debugging.
+
+(defun dump-frame (f &optional (out *standard-output*))
+ (declare (type frame f))
+ (loop for (var . value) in (frame-bindings f)
+ do (format out "~&~A~VT= ~A~%" var 8 value))
+ )
+(defun dump-environment (env &optional (out *standard-output*))
+ (declare (type environment env))
+ (if (empty-environment-p env)
+ (format out ">>> Empty unify environment ~S.~%" env)
+ (loop initially (format out ">>> Dumping unify environment ~S.~%" env)
+ for fr in (environment-frames env)
+ for fr-n downfrom (list-length (environment-frames env))
+ do (format out ">>> Frame ~D:~%" fr-n)
+ do (dump-frame fr out)
+ do (terpri out)
+ )))
;;;; end of file -- substitutions.lisp --
diff -rN -u old-cl-unification-1/templates-hierarchy.lisp new-cl-unification-1/templates-hierarchy.lisp
--- old-cl-unification-1/templates-hierarchy.lisp 2013-07-25 02:31:29.000000000 +0000
+++ new-cl-unification-1/templates-hierarchy.lisp 2013-07-25 02:31:29.000000000 +0000
@@ -2,6 +2,8 @@
;;;; templates-hierarchy.lisp --
+;;;; See file COPYING for copyright licensing information.
+
(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
;;; Templates.
diff -rN -u old-cl-unification-1/test/unification-tests.lisp new-cl-unification-1/test/unification-tests.lisp
--- old-cl-unification-1/test/unification-tests.lisp 2013-07-25 02:31:29.000000000 +0000
+++ new-cl-unification-1/test/unification-tests.lisp 2013-07-25 02:31:29.000000000 +0000
@@ -1,13 +1,13 @@
;;;; -*- Mode: Lisp -*-
;;;; unification-tests.lisp --
-;;;; 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"))
(in-package "UNIFY.TESTS")
;; nil seems like a lousy default for this
@@ -43,7 +43,7 @@
(test-error (unify "I am a string" "I am A string")
:condition-type 'unification-failure)
- (test t (let ((*unify-string-case-insensitive-p* t))
+ (test t (let ((*unify-string-case-sensitive-p* nil))
(unify:environment-p (unify "I am a string" "I am A string"))))
)
@@ -102,6 +102,8 @@
(test t (unify:environment-p (unify #C(0 1) #T(complex #C(0 1)))))
(test '(42 T) (v? '?x (unify #T(number ?x) 42)) :multiple-values t)
+ (test '(42 T) (v? '?x (unify #(0 1 42 3 4 5) #T(sequence 0 1 ?x 3 4 5)))
+ :multiple-values t)
(test-error (unify 42 #T(float 42.0))
:condition-type 'unification-failure
@@ -111,6 +113,8 @@
)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
(defclass test1 ()
((a :initarg :a :accessor a)
(b :initarg :b :accessor b)))
@@ -118,6 +122,8 @@
(defstruct s-root a)
(defstruct (s-child (:include s-root)) b)
+)
+
(with-tests (:name "advanced templates unification")
(test '(a T) (v? '?x (unify #2A((1 #T(symbol ?x) 3) (_ _ _))
diff -rN -u old-cl-unification-1/unification-package.lisp new-cl-unification-1/unification-package.lisp
--- old-cl-unification-1/unification-package.lisp 2013-07-25 02:31:29.000000000 +0000
+++ new-cl-unification-1/unification-package.lisp 2013-07-25 02:31:29.000000000 +0000
@@ -3,12 +3,12 @@
;;;; unification-package.lisp --
;;;; Package definition for the CL-UNIFICATION library.
;;;;
-;;;; 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.
(defpackage "IT.UNIMIB.DISCO.MA.CL.EXT.DACF.UNIFICATION" (:use "CL")
- (:nicknames "CL.EXT.DACF.UNIFICATION" "UNIFY" "unify")
+ (:nicknames "CL.EXT.DACF.UNIFICATION" "UNIFY" "unify" "CL-UNIFICATION")
(:documentation "The CL.EXT.DACF.UNIFICATION Package.
This package contains all the definitions necessary for the general
@@ -16,18 +16,9 @@
The package also has the \"UNIFY\" nickname.")
(:export
- "ENABLE-TEMPLATE-READER"
- "MAKE-TEMPLATE"
- "TEMPLATEP"
- "TEMPLATE-SPEC")
-
- (:export
- "*UNIFY-STRING-CASE-INSENSITIVE-P*"
+ "*UNIFY-STRING-CASE-SENSITIVE-P*"
"UNIFY"
- "FIND-VARIABLE-VALUE"
- "V?"
- "MAKE-EMPTY-ENVIRONMENT"
"APPLY-SUBSTITUTION"
"UNIFICATION-FAILURE"
@@ -36,7 +27,29 @@
(:export
"ENVIRONMENT"
- "ENVIRONMENT-P")
+ "ENVIRONMENT-P"
+ "MAKE-EMPTY-ENVIRONMENT"
+ "EMPTY-ENVIRONMENT-P"
+ "MAKE-SHARED-ENVIRONMENT"
+ "COPY-ENVIRONMENT"
+
+ "PUSH-FRAME"
+ "POP-FRAME"
+
+ "BINDING-VARIABLE"
+ "BINDING-VALUE"
+
+ "EXTEND-ENVIRONMENT"
+ "FILL-ENVIRONMENT"
+ "FILL-ENVIRONMENT*"
+
+ "FIND-VARIABLE-VALUE"
+ "V?"
+
+ "NEW-VAR"
+ "VARIABLEP"
+ "VARIABLE-ANY-P"
+ )
(:export
"MATCH"
@@ -55,6 +68,15 @@
"UNIFY-EQUATIONS"
"UNIFY-EQUATIONS*")
+ (:export
+ "ENABLE-TEMPLATE-READER"
+ "MAKE-TEMPLATE"
+ "TEMPLATEP"
+ "TEMPLATE-SPEC"
+
+ "COLLECT-TEMPLATE-VARS"
+ )
+
#+cl-ppcre
(:export
"REGULAR-EXPRESSION"
diff -rN -u old-cl-unification-1/unifier.lisp new-cl-unification-1/unifier.lisp
--- old-cl-unification-1/unifier.lisp 2013-07-25 02:31:29.000000000 +0000
+++ new-cl-unification-1/unifier.lisp 2013-07-25 02:31:29.000000000 +0000
@@ -3,6 +3,8 @@
;;; unifier.lisp
;;; General CL structures unifier.
+;;;; See file COPYING for copyright licensing information.
+
(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
(defgeneric unify (a b &optional env &key &allow-other-keys)
@@ -91,7 +93,7 @@
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.
+*UNIFY-STRING-CASE-SENSITIVE-P*, which defaults to T.
If A and B unify then an unmodified environment ENV is returned,
otherwise an error of type UNIFICATION-FAILURE is signaled."
(cond ((and case-sensitive (char= a b))
@@ -113,7 +115,7 @@
Two strings A and B unify if and only if they satisfy either #'STRING= or
#'STRING-EQUAL. The choice of which of test to perform (#'STRING= or #'STRING-EQUAL)
is made according to the value of the variable
-*UNIFY-STRING-CASE-INSENSITIVE-P*, which defaults to NIL.
+*UNIFY-STRING-CASE-SENSITIVE-P*, which defaults to T.
If A and B unify then an unmodified environment ENV is returned,
otherwise an error of type UNIFICATION-FAILURE is signaled."
(cond ((and case-sensitive (string= a b))
@@ -440,7 +442,7 @@
:key-variable-test #'valid-template-p
:rest-variable-test #'valid-template-p
)
-
+
(let* ((n-vars (list-length vars))
(n-optionals (list-length optionals))
(env (unify (subseq a 0 (min ll (list-length vars)))
@@ -476,7 +478,7 @@
:format-arguments (list a b)))
-(defmethod unify ((a vector) (b vector-template)
+(defmethod unify ((a vector) (b sequence-template)
&optional (env (make-empty-environment))
&key &allow-other-keys)
(let ((template-lambda-list (sequence-template-lambda-list b))
@@ -489,7 +491,7 @@
:key-variable-test #'valid-template-p
:rest-variable-test #'valid-template-p
)
-
+
(let ((n-vars (list-length vars))
(n-optionals (list-length optionals))
)
@@ -936,7 +938,7 @@
;; This is needed because of different precedence rules among lisps
;; in COMPUTE-APPLICABLE-METHODS when NIL has to matched against
;; SYMBOL and LIST.
-
+
;; We know (assume) that VAR is not NIL.
nil)
diff -rN -u old-cl-unification-1/variables.lisp new-cl-unification-1/variables.lisp
--- old-cl-unification-1/variables.lisp 2013-07-25 02:31:29.000000000 +0000
+++ new-cl-unification-1/variables.lisp 2013-07-25 02:31:29.000000000 +0000
@@ -1,10 +1,19 @@
-;;; -*- Mode: Lisp -*-
+;;;; -*- Mode: Lisp -*-
+
+;;;; variables.lisp --
+
+;;;; See file COPYING for copyright licensing information.
(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
-(defun make-var-name (&optional (s (gensym "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))
(defun variablep (x)