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)))