[cl-unification-cvs] CVS cl-unification

[mantoniotti]

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 , at spec))))))
+    (unify (subseq a from to)
+	   (make-template seq-template-kind `(,seq-template-kind , at 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)))