Wed Apr 15 10:14:24 UTC 2009 mantoniotti

* Major API change to 'unify'. It now accepts keywords. Old code

Major API change to 'unify'. It now accepts keywords. Old code

shouls not be affected, but new code is now more flexible. Look the

the STRING and (new) CHARACTER methods to see how this change is

affecting the code.

-(defgeneric unify (a b &optional env)

+(defgeneric unify (a b &optional env &key &allow-other-keys)

-(defmethod unify ((a symbol) (b list) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b list)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((b list) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b list) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a list) (b list) &optional (env (make-empty-environment)))

+(defmethod unify ((a list) (b list)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a number) (b number) &optional (env (make-empty-environment)))

+(defmethod unify ((a number) (b number)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defparameter *unify-string-case-insensitive-p* nil)

+(defparameter *unify-string-case-sensitive-p* t)

-(defmethod unify ((a string) (b string) &optional (env (make-empty-environment)))

+(defmethod unify ((a character) (b character)

+ &optional (env (make-empty-environment))

+ &key

+ (case-sensitive *unify-string-case-sensitive-p*)

+ &allow-other-keys)

+ "Unifies two strings A and B.

+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.

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

+ env)

+ ((char-equal a b)

+ env)

+ (t

+ (error 'unification-failure

+ :format-control "Connot unify two different characters: ~S ~S."

+ :format-arguments (list a b)))))

+

+

+(defmethod unify ((a string) (b string)

+ &optional (env (make-empty-environment))

+ &key

+ (case-sensitive *unify-string-case-sensitive-p*)

+ &allow-other-keys)

- (cond ((and *unify-string-case-insensitive-p* (string-equal a b))

+ (cond ((and case-sensitive (string= a b))

- ((string= a b)

+ ((string-equal a b)

-(defmethod unify ((a symbol) (b string) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b string)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((b string) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b string) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a symbol) (b symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a symbol) (b t) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b t)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((b t) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b t) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a symbol) (b array) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b array)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- :format-control "Cannot unify a symbol with an array or vector: ~S and ~S."

+ :format-control "Cannot unify a symbol with ~

+ an array or vector: ~S and ~S."

-(defmethod unify ((b array) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b array) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((as vector) (bs vector) &optional (env (make-empty-environment)))

+(defmethod unify ((as vector) (bs vector)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((s1 sequence) (s2 sequence) &optional (env (make-empty-environment)))

+(defmethod unify ((s1 sequence) (s2 sequence)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((as array) (bs array) &optional (env (make-empty-environment)))

+(defmethod unify ((as array) (bs array)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a t) (b t) &optional (env (make-empty-environment)))

+(defmethod unify ((a t) (b t)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((x template) (y template) &optional (env (make-empty-environment)))

+(defmethod unify ((x template) (y template)

+ &optional (env)

+ &key &allow-other-keys)

- :format-control "Unification of two templates of type ~A and ~A has not been yet implemented."

+ :format-control "Unification of two templates of type ~A and ~A ~

+ has not been yet implemented."

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a symbol) (b symbol-template) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b symbol-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((b symbol-template) (a symbol) &optional (env (make-empty-environment)))

+(defmethod unify ((b symbol-template) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a symbol) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a symbol) (b template)

+ &optional (env)

+ &key &allow-other-keys)

-(defmethod unify ((b template) (a symbol) &optional (env (make-empty-environment)))

+

+(defmethod unify ((b template) (a symbol)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a number) (b number-template) &optional (env (make-empty-environment)))

+(defmethod unify ((a number) (b number-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((b number-template) (a number) &optional (env (make-empty-environment)))

+(defmethod unify ((b number-template) (a number)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a number) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a number) (b template)

+ &optional (env)

+ &key &allow-other-keys)

-(defmethod unify ((b template) (a number) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a number)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a sequence) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a sequence) (b template)

+ &optional (env)

+ &key &allow-other-keys)

- :format-control "Cannot unify a sequence with a non sequence or non sequence access template: ~S ~S."

+ :format-control "Cannot unify a sequence with a non sequence ~

+ or non sequence access template: ~S and ~S."

-(defmethod unify ((b template) (a sequence) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a sequence)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+#| Needs to be fixed.

+(defmethod unify ((a list) (b lambda-template) &optional (env (make-empty-environment)))

+ (unify a (template-spec b) env))

+

+

+(defmethod unify ((b lambda-template) (a list) &optional (env (make-empty-environment)))

+ (unify (template-spec b) a env))

+|#

+

+

-(defmethod unify ((a list) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a list) (b template)

+ &optional (env)

+ &key &allow-other-keys)

-(defmethod unify ((a list) (b sequence-template) &optional (env (make-empty-environment)))

+(defmethod unify ((a list) (b sequence-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((b template) (a list) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a list)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a vector) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a vector) (b template)

+ &optional (env)

+ &key &allow-other-keys)

-(defmethod unify ((a vector) (b vector-template) &optional (env (make-empty-environment)))

+(defmethod unify ((a vector) (b vector-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((b template) (a vector) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a vector)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a array) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a array) (b template)

+ &optional (env)

+ &key &allow-other-keys)

- :format-control "Cannot unify an array with a non array or non array access template: ~S ~S."

+ :format-control "Cannot unify an array with a non array ~

+ or non array access template: ~S and ~S."

-(defmethod unify ((b template) (a array) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a array)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- (apply #'array-row-major-index array (append indexes (list 0))))))

+ (apply #'array-row-major-index

+ array

+ (append indexes (list 0))))))

-(defmethod unify ((a array) (b array-template) &optional (env (make-empty-environment)))

+(defmethod unify ((a array) (b array-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a standard-object) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a standard-object) (b template)

+ &optional (env)

+ &key &allow-other-keys)

- :format-control "Cannot unify a standard object with a non standard object template: ~S ~S."

+ :format-control "Cannot unify a standard object with a ~

+ non standard object template: ~S and ~S."

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((b template) (a standard-object) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a standard-object)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a structure-object) (b template) &optional (env (make-empty-environment)))

+(defmethod unify ((a structure-object) (b template)

+ &optional (env)

+ &key &allow-other-keys)

- :format-control "Cannot unify a structure object with a non structure object template: ~S ~S."

+ :format-control "Cannot unify a structure object with ~

+ a non structure object template: ~S and ~S."

- &optional (env (make-empty-environment)))

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

- :format-control "Cannot unify an instance of ~S with a template for structure ~S."

+ :format-control "Cannot unify an instance of ~S with a ~

+ template for structure ~S."

-(defmethod unify ((b template) (a structure-object) &optional (env (make-empty-environment)))

+(defmethod unify ((b template) (a structure-object)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-(defmethod unify ((a sequence) (b subseq-template) &optional (env (make-empty-environment)))

+;;; SEQUENCE

+;;; For non LIST and non VECTOR possible SEQUENCE types.

+

+(defmethod unify ((a sequence) (b subseq-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (declare (ignore subseq-kwd))

- (seq-template-kind (if (symbolp seq-type) seq-type (first seq-type))) ; Stupid FTTB.

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

+ env))))

+

+

+;;; LIST

+

+(defmethod unify ((a list) (b subseq-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (subseq-kwd from to &rest spec)

+ (template-spec b)

+ (declare (ignore subseq-kwd))

- (make-template seq-template-kind `(,seq-template-kind ,@spec))

- env))))

+ (make-template 'list `(list ,@spec))

+ env)))

+

+

+;;; VECTOR

+

+(defmethod unify ((a vector) (b subseq-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (subseq-kwd from to &rest spec)

+ (template-spec b)

+ (declare (ignore subseq-kwd))

+ (let ((seq-type (type-of a)))

+ (unify (subseq a from to)

+ (make-template seq-type `(,seq-type ,@spec))

+ env))))

-(defmethod unify ((b subseq-template) (a sequence) &optional (env (make-empty-environment)))

+(defmethod unify ((b subseq-template) (a sequence)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

-;;; Expression template AREF methods.

+;;; Expression templates

-(defmethod unify ((a array) (b aref-template) &optional (env (make-empty-environment)))

+;;; AREF methods.

+

+(defmethod unify ((a array) (b aref-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+;;; Necessary due to standard method sorting.

+

+(defmethod unify ((a vector) (b aref-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (aref-kwd indexes value-template)

+ (template-spec b)

+ (declare (ignore aref-kwd))

+ ;; Missing check on index spec.

+ (when (and (consp indexes) (> (length indexes) 1))

+ (error 'unification-failure

+ :format-control "Cannot unify a vector with an element ~

+ too many dimensions down~@

+ (AREF #(...)~{ ~S~})."

+ :format-arguments (list indexes)

+ ))

+ (unless (consp indexes)

+ (setf indexes (list indexes)))

+ (unify (apply #'aref a indexes) value-template env)))

+

+

+(defmethod unify ((b aref-template) (a array)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (unify a b env))

+

+

+;;; ELT methods.

+;;; LIST and VECTOR methods must be specified separatedly because of

+;;; the UNIFY (VECTOR TEMPLATE) methods above. It is a snag, but a

+;;; relatively small one. Besides, they are more efficient.

+;;; The (SEQUENCE ELT-TEMPLATE) ELT-TEMPLATE method is left for those

+;;; sequences which, according to the ANSI spec may exist and not be

+;;; either VECTOR or LIST.

+

+(defmethod unify ((a sequence) (b elt-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (elt-kwd index value-template)

+ (template-spec b)

+ (declare (ignore elt-kwd)

+ (type fixnum index))

+ ;; Missing index check.

+ (unify (elt a index) value-template env)))

+

+

+(defmethod unify ((a vector) (b elt-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (elt-kwd index value-template)

+ (template-spec b)

+ (declare (ignore elt-kwd)

+ (type fixnum index))

+ ;; Missing index check.

+ (unify (aref a index) value-template env)))

+

+

+(defmethod unify ((a list) (b elt-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (elt-kwd index value-template)

+ (template-spec b)

+ (declare (ignore elt-kwd)

+ (type fixnum index))

+ ;; Missing index check.

+ (unify (nth index a) value-template env)))

+

+

+(defmethod unify ((b elt-template) (a sequence)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (unify a b env))

+

+

+;;; NTH methods.

+

+(defmethod unify ((a list) (b nth-template)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (destructuring-bind (nth-kwd index value-template)

+ (template-spec b)

+ (declare (ignore nth-kwd))

+ ;; Missing index check.

+ (unify (nth index a) value-template env)))

+

+(defmethod unify ((b nth-template) (a list)

+ &optional (env (make-empty-environment))

+ &key &allow-other-keys)

+ (unify a b env))

+

+

+;;;---------------------------------------------------------------------------

+;;; Utilities.

+

+(defun unify* (a b &optional (env (make-empty-environment)))

+ (ignore-errors (unify a b env)))

+

+

+(defun unify-equations (eqns &optional (env (make-empty-environment)))

+ (loop for (a b) in eqns

+ for result-env = (unify a b env) then (unify a b result-env)

+ finally (return result-env)))

+

+

+(defun unify-equations* (lhss rhss &optional (env (make-empty-environment)))

+ (loop for a in lhss

+ for b in rhss

+ for result-env = (unify a b env) then (unify a b result-env)

+ finally (return result-env)))

+

+

+(defmethod occurs-in-p ((var symbol) (pat character) env)

+ (declare (ignore env))

+ nil)

+

+

- (warn "Occurrence test unimplemented for pattern ~S of type ~S; returning false."

+ (warn "Occurrence test unimplemented for pattern ~S of type ~S in variable ~S;~@

+ returning false."

- (type-of pat))

+ (type-of pat)

+ var)