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

--- old-cl-unification-1/templates-hierarchy.lisp 2013-07-21 19:59:52.000000000 +0000

+++ new-cl-unification-1/templates-hierarchy.lisp 2013-07-21 19:59:52.000000000 +0000

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

--- old-cl-unification-1/unifier.lisp 2013-07-21 19:59:52.000000000 +0000

+++ new-cl-unification-1/unifier.lisp 2013-07-21 19:59:52.000000000 +0000

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