Update of /project/cl-unification/cvsroot/cl-unification
In directory clnet:/tmp/cvs-serv30069
Modified Files:
templates-hierarchy.lisp unifier.lisp
Log Message:
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
--- /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp 2005/04/27 20:44:25 1.2
+++ /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp 2006/07/19 21:52:34 1.3
@@ -221,17 +221,33 @@
;;; Setting up the reader macro.
-(defun |#T-reader| (stream subchar arg)
+#||
+(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)))))
+||#
+
+
+;;; 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)))
+ ))
(eval-when (:load-toplevel :execute)
- (set-dispatch-macro-character #\# #\T #'|#T-reader|))
+ (set-dispatch-macro-character #\# #\T #'|sharp-T-reader|))
(defmethod make-template ((kind null) (spec symbol))
(assert (null spec) (spec) "MAKE-TEMPLATE called erroneously with ~S and ~S." kind spec)
--- /project/cl-unification/cvsroot/cl-unification/unifier.lisp 2005/10/25 19:17:33 1.4
+++ /project/cl-unification/cvsroot/cl-unification/unifier.lisp 2006/07/19 21:52:34 1.5
@@ -230,6 +230,7 @@
;;; Special catch all method.
(defmethod unify ((x template) (y template) &optional (env (make-empty-environment)))
+ (declare (ignore env))
(error 'unification-failure
:format-control "Unification of two templates of type ~A and ~A has not been yet implemented."
:format-arguments (list (class-name (class-of x))
@@ -239,15 +240,23 @@
;;;---------------------------------------------------------------------------
;;; NIL special unification methods.
-(defmethod unify ((x null) (nt nil-template) &optional (env (make-empty-environment)))
+(defmethod unify ((x null) (y null)
+ &optional (env (make-empty-environment)))
+ env)
+
+
+(defmethod unify ((x null) (nt nil-template)
+ &optional (env (make-empty-environment)))
env)
-(defmethod unify ((nt nil-template) (x null) &optional (env (make-empty-environment)))
+(defmethod unify ((nt nil-template) (x null)
+ &optional (env (make-empty-environment)))
env)
-(defmethod unify ((nt1 nil-template) (nt2 nil-template) &optional (env (make-empty-environment)))
+(defmethod unify ((nt1 nil-template) (nt2 nil-template)
+ &optional (env (make-empty-environment)))
env)
@@ -299,6 +308,7 @@
;;; Sequence (List) template methods
(defmethod unify ((a sequence) (b template) &optional (env (make-empty-environment)))
+ (declare (ignore env))
(error 'unification-failure
:format-control "Cannot unify a sequence with a non sequence or non sequence access template: ~S ~S."
:format-arguments (list a b)))
@@ -354,6 +364,7 @@
;;; Vector template methods.
(defmethod unify ((a vector) (b template) &optional (env (make-empty-environment)))
+ (declare (ignore env))
(error 'unification-failure
:format-control "Cannot unify a vector with a non-vector template: ~S ~S."
:format-arguments (list a b)))
@@ -398,6 +409,7 @@
;;; Array template methods.
(defmethod unify ((a array) (b template) &optional (env (make-empty-environment)))
+ (declare (ignore env))
(error 'unification-failure
:format-control "Cannot unify an array with a non array or non array access template: ~S ~S."
:format-arguments (list a b)))
@@ -447,7 +459,7 @@
;; Template is (array (['*' | <element type>] [<dimension spec>]) <shape template>)
(destructuring-bind (array-kwd type-spec shape-template)
template-spec
- (declare (ignore array-kwd))
+ (declare (ignore array-kwd type-spec))
;; Missing check for type-spec.
(unify-array-rows a shape-template env))
)))
@@ -458,11 +470,12 @@
;;; Standard object template methods.
(defmethod unify ((a standard-object) (b template) &optional (env (make-empty-environment)))
+ (declare (ignore env))
(error 'unification-failure
:format-control "Cannot unify a standard object with a non standard object template: ~S ~S."
:format-arguments (list a b)))
-#| Old version with heavy syntax
+#|| Old version with heavy syntax
(defmethod unify ((a standard-object) (b standard-object-template)
&optional (env (make-empty-environment)))
(destructuring-bind (class &rest template-slot-specs)
@@ -484,7 +497,7 @@
then (slot-spec-unify accessor-spec reader value-template mgu)
finally (return mgu))
env))))
-|#
+||#
(defmethod unify ((a standard-object) (b standard-object-template)
@@ -519,6 +532,7 @@
;;; Structure object template methods.
(defmethod unify ((a structure-object) (b template) &optional (env (make-empty-environment)))
+ (declare (ignore env))
(error 'unification-failure
:format-control "Cannot unify a structure object with a non structure object template: ~S ~S."
:format-arguments (list a b)))
@@ -553,7 +567,9 @@
(let* ((seq-type (type-of a))
(seq-template-kind (if (symbolp seq-type) seq-type (first seq-type))) ; Stupid FTTB.
)
- (unify (subseq a from to) (make-template seq-template-kind `(,seq-template-kind ,@spec))))))
+ (unify (subseq a from to)
+ (make-template seq-template-kind `(,seq-template-kind ,@spec))
+ env))))
(defmethod unify ((b subseq-template) (a sequence) &optional (env (make-empty-environment)))
@@ -597,7 +613,7 @@
-#|
+#||
(defmethod occurs-in-p ((var symbol) pat env)
(cond ((variablep pat)
(or (eq var pat)
@@ -612,7 +628,8 @@
(occurs-in-p var (rest pat) env)))
(t
(error "unimplemented"))))
-|#
+||#
+
(defmethod occurs-in-p ((var symbol) (pat symbol) env)
(when (variablep pat)
@@ -623,10 +640,21 @@
(occurs-in-p var value env)))
)))
+
(defmethod occurs-in-p ((var symbol) (pat list) env)
(or (occurs-in-p var (first pat) env)
(occurs-in-p var (rest pat) env)))
+
+(defmethod occurs-in-p ((var symbol) (pat null) env)
+ ;; This is needed because of different precedence rules among lisps
+ ;; in COMPUTE-APPLICABLE-METHODS when NIL has to matched against
+ ;; SYMBOL and LIST.
+
+ ;; We know (assume) that VAR is not NIL.
+ nil)
+
+
(defmethod occurs-in-p ((var symbol) (pat array) env)
(loop for i from 0 below (array-total-size pat)
thereis (occurs-in-p var (row-major-aref pat i) env)))
