repos / cl-unification / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
Use *unify-string-case-sensitive-p* consistently.
Annotate for file /unifier.lisp
2004-11-17 mantoniotti 1 ;;; -*- Mode: Lisp -*-
22:19:54 ' 2
' 3 ;;; unifier.lisp
' 4 ;;; General CL structures unifier.
' 5
2011-04-02 mantoniotti 6 ;;;; See file COPYING for copyright licensing information.
04:05:18 ' 7
2004-11-17 mantoniotti 8 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
22:19:54 ' 9
2009-04-15 mantoniotti 10 (defgeneric unify (a b &optional env &key &allow-other-keys)
2004-11-17 mantoniotti 11 (:documentation
22:19:54 ' 12 "Unifies two objects A and B given a substitution ENV.
' 13 A is a Common Lisp object and B is either a Common Lisp object or a
' 14 \"template\", A and B can be commuted.
' 15
' 16 The unification rules are rather complex. Each method of the generic
' 17 function implements a specific rule of unification.
' 18
' 19 The generic function returns a `substitution' upon success or it
' 20 signals a UNIFICATION-FAILURE condition upon failure."))
' 21
' 22
' 23
' 24 ;;;===========================================================================
' 25 ;;; Simple, non template methods.
' 26
2009-04-15 mantoniotti 27 (defmethod unify ((a symbol) (b list)
10:14:24 ' 28 &optional (env (make-empty-environment))
' 29 &key &allow-other-keys)
2004-11-17 mantoniotti 30 "Unifies a symbol A and a list B in an environment ENV.
22:19:54 ' 31 If A is not a variable then an error of type UNIFICATION-FAILURE is
' 32 signaled. If A is a unification variable, then the environment ENV is
' 33 extended with a binding for A to B, unless the occurrence check is
' 34 called and fails, in which case an error is signaled."
' 35 (cond ((variable-any-p a) env)
' 36 ((variablep a) (var-unify a b env))
' 37 (t (error 'unification-failure
' 38 :format-control "Cannot unify a symbol with a list: ~S ~S."
' 39 :format-arguments (list a b)))))
' 40
' 41
2009-04-15 mantoniotti 42 (defmethod unify ((b list) (a symbol)
10:14:24 ' 43 &optional (env (make-empty-environment))
' 44 &key &allow-other-keys)
2004-11-17 mantoniotti 45 "Unifies a symbol B and a list A in an environment ENV.
22:19:54 ' 46 If A is not a variable then an error of type UNIFICATION-FAILURE is
' 47 signaled. If A is a unification variable, then the environment ENV is
' 48 extended with a binding for A to B, unless the occurrence check is
' 49 called and fails, in which case an error is signaled."
' 50 (cond ((variable-any-p a) env)
' 51 ((variablep a) (var-unify a b env))
' 52 (t (error 'unification-failure
' 53 :format-control "Cannot unify a list with a symbol: ~S ~S."
' 54 :format-arguments (list b a)))))
' 55
' 56
2009-04-15 mantoniotti 57 (defmethod unify ((a list) (b list)
10:14:24 ' 58 &optional (env (make-empty-environment))
' 59 &key &allow-other-keys)
2004-11-17 mantoniotti 60 "Unifies a list A and a list B in an environment ENV.
22:19:54 ' 61 The unification procedure proceedes recursively on each element of
' 62 both lists. If two elements cannot be unified then an error of type
' 63 UNIFICATION-FAILURE is signaled. Otherwise a possibly extended
' 64 environment is returned."
' 65 (unify (rest a) (rest b) (unify (first a) (first b) env)))
' 66
' 67
' 68
2009-04-15 mantoniotti 69 (defmethod unify ((a number) (b number)
10:14:24 ' 70 &optional (env (make-empty-environment))
' 71 &key &allow-other-keys)
2004-11-17 mantoniotti 72 "Unifies two numbers A and B.
22:19:54 ' 73 Two numbers unify only if and only if they are equal as per the function #'=, in
' 74 which case an unmodified envirironment ENV is returned.
' 75 Otherwise an error of type UNIFICATION-FAILURE is signalled.
' 76 Of course, asking for unification of two floating point numbers may
' 77 not yield the expected result."
' 78 (if (= a b)
' 79 env
' 80 (error 'unification-failure
' 81 :format-control "Cannot unify two different numbers: ~S ~S."
' 82 :format-arguments (list a b))))
' 83
' 84
2009-04-15 mantoniotti 85 (defparameter *unify-string-case-sensitive-p* t)
2004-11-17 mantoniotti 86
2009-04-15 mantoniotti 87 (defmethod unify ((a character) (b character)
10:14:24 ' 88 &optional (env (make-empty-environment))
' 89 &key
' 90 (case-sensitive *unify-string-case-sensitive-p*)
' 91 &allow-other-keys)
' 92 "Unifies two strings A and B.
' 93 Two CHARACTERs A and B unify if and only if they satisfy either #'CHAR= or
' 94 #'CHAR-EQUAL. The choice of which of test to perform (#'CHAR= or #'CHAR-EQUAL)
' 95 is made according to the value of the variable
2011-04-02 rbrown 96 *UNIFY-STRING-CASE-SENSITIVE-P*, which defaults to T.
2009-04-15 mantoniotti 97 If A and B unify then an unmodified environment ENV is returned,
10:14:24 ' 98 otherwise an error of type UNIFICATION-FAILURE is signaled."
' 99 (cond ((and case-sensitive (char= a b))
' 100 env)
2010-01-20 pix 101 ((and (not case-sensitive) (char-equal a b))
2009-04-15 mantoniotti 102 env)
10:14:24 ' 103 (t
' 104 (error 'unification-failure
2010-01-20 pix 105 :format-control "Cannot unify two different characters: ~S ~S."
2009-04-15 mantoniotti 106 :format-arguments (list a b)))))
10:14:24 ' 107
' 108
' 109 (defmethod unify ((a string) (b string)
' 110 &optional (env (make-empty-environment))
' 111 &key
' 112 (case-sensitive *unify-string-case-sensitive-p*)
' 113 &allow-other-keys)
2004-11-17 mantoniotti 114 "Unifies two strings A and B.
22:19:54 ' 115 Two strings A and B unify if and only if they satisfy either #'STRING= or
' 116 #'STRING-EQUAL. The choice of which of test to perform (#'STRING= or #'STRING-EQUAL)
' 117 is made according to the value of the variable
2011-04-02 rbrown 118 *UNIFY-STRING-CASE-SENSITIVE-P*, which defaults to T.
2004-11-17 mantoniotti 119 If A and B unify then an unmodified environment ENV is returned,
22:19:54 ' 120 otherwise an error of type UNIFICATION-FAILURE is signaled."
2009-04-15 mantoniotti 121 (cond ((and case-sensitive (string= a b))
2004-11-17 mantoniotti 122 env)
2010-01-20 pix 123 ((and (not case-sensitive) (string-equal a b))
2004-11-17 mantoniotti 124 env)
22:19:54 ' 125 (t
' 126 (error 'unification-failure
2010-01-20 pix 127 :format-control "Cannot unify two different strings: ~S ~S."
2004-11-17 mantoniotti 128 :format-arguments (list a b)))))
22:19:54 ' 129
' 130
2009-04-15 mantoniotti 131 (defmethod unify ((a symbol) (b string)
10:14:24 ' 132 &optional (env (make-empty-environment))
' 133 &key &allow-other-keys)
2004-11-17 mantoniotti 134 (cond ((variable-any-p a) env)
2005-05-20 mantoniotti 135 ((variablep a) (var-unify a b env))
2004-11-17 mantoniotti 136 (t (error 'unification-failure
2005-05-20 mantoniotti 137 :format-control "Cannot unify a symbol with a string: ~S ~S."
15:19:53 ' 138 :format-arguments (list a b)))))
2004-11-17 mantoniotti 139
22:19:54 ' 140
2009-04-15 mantoniotti 141 (defmethod unify ((b string) (a symbol)
10:14:24 ' 142 &optional (env (make-empty-environment))
' 143 &key &allow-other-keys)
2004-11-17 mantoniotti 144 (cond ((variable-any-p a) env)
2005-05-20 mantoniotti 145 ((variablep a) (var-unify a b env))
2004-11-17 mantoniotti 146 (t (error 'unification-failure
22:19:54 ' 147 :format-control "Cannot unify a string with a symbol: ~S ~S."
' 148 :format-arguments (list b a)))))
' 149
' 150
2009-04-15 mantoniotti 151 (defmethod unify ((a symbol) (b symbol)
10:14:24 ' 152 &optional (env (make-empty-environment))
' 153 &key &allow-other-keys)
2004-11-17 mantoniotti 154 (cond ((variable-any-p a) env)
22:19:54 ' 155 ((variablep a) (var-unify a b env))
' 156 ((variable-any-p b) env)
' 157 ((variablep b) (var-unify b a env))
' 158 ((eq a b) env)
' 159 (t (error 'unification-failure
' 160 :format-control "Cannot unify two different symbols: ~S ~S."
' 161 :format-arguments (list a b)))))
' 162
' 163
2009-04-15 mantoniotti 164 (defmethod unify ((a symbol) (b t)
10:14:24 ' 165 &optional (env (make-empty-environment))
' 166 &key &allow-other-keys)
2004-11-17 mantoniotti 167 (cond ((variable-any-p a) env)
2005-05-20 mantoniotti 168 ((variablep a) (var-unify a b env))
2004-11-17 mantoniotti 169 (t (call-next-method))))
22:19:54 ' 170
' 171
2009-04-15 mantoniotti 172 (defmethod unify ((b t) (a symbol)
10:14:24 ' 173 &optional (env (make-empty-environment))
' 174 &key &allow-other-keys)
2004-11-17 mantoniotti 175 (cond ((variable-any-p a) env)
2005-05-20 mantoniotti 176 ((variablep a) (var-unify a b env))
2004-11-17 mantoniotti 177 (t (call-next-method))))
22:19:54 ' 178
' 179
2009-04-15 mantoniotti 180 (defmethod unify ((a symbol) (b array)
10:14:24 ' 181 &optional (env (make-empty-environment))
' 182 &key &allow-other-keys)
2004-11-17 mantoniotti 183 (cond ((variable-any-p a) env)
22:19:54 ' 184 ((variablep a) (var-unify a b env))
' 185 (t (error 'unification-failure
2009-04-15 mantoniotti 186 :format-control "Cannot unify a symbol with ~
10:14:24 ' 187 an array or vector: ~S and ~S."
2004-11-17 mantoniotti 188 :format-arguments (list a b)))))
22:19:54 ' 189
' 190
2009-04-15 mantoniotti 191 (defmethod unify ((b array) (a symbol)
10:14:24 ' 192 &optional (env (make-empty-environment))
' 193 &key &allow-other-keys)
2004-11-17 mantoniotti 194 (cond ((variable-any-p a) env)
22:19:54 ' 195 ((variablep a) (var-unify a b env))
' 196 (t (error 'unification-failure
' 197 :format-control "Cannot unify an array or vector with a symbol: ~S and ~S."
' 198 :format-arguments (list a b)))))
' 199
' 200
2009-04-15 mantoniotti 201 (defmethod unify ((as vector) (bs vector)
10:14:24 ' 202 &optional (env (make-empty-environment))
' 203 &key &allow-other-keys)
2004-11-17 mantoniotti 204 (unless (= (length as) (length bs))
22:19:54 ' 205 (error 'unification-failure
' 206 :format-control "Cannot unify two vectors of different length: ~D and ~D."
' 207 :format-arguments (list (length as) (length bs))))
' 208 (loop for a across as
' 209 for b across bs
' 210 for mgu = (unify a b env) then (unify a b mgu)
' 211 finally (return mgu)))
' 212
' 213
2009-04-15 mantoniotti 214 (defmethod unify ((s1 sequence) (s2 sequence)
10:14:24 ' 215 &optional (env (make-empty-environment))
' 216 &key &allow-other-keys)
2004-11-17 mantoniotti 217 (unless (= (length s1) (length s2))
22:19:54 ' 218 (error 'unification-failure
' 219 :format-control "Cannot unify two sequences of different length: ~D and ~D."
' 220 :format-arguments (list (length s1) (length s2))))
' 221 (loop for i from 0 below (length s1)
' 222 for j from 0 below (length s2)
' 223 for mgu = (unify (elt s1 i) (elt s2 j) env) then (unify (elt s1 i) (elt s2 j) mgu)
' 224 finally (return mgu)))
' 225
' 226
' 227
' 228 (defgeneric untyped-unify (a b &optional env))
' 229
2009-12-17 mantoniotti 230 (defmethod untyped-unify ((as list) (bs vector)
16:44:46 ' 231 &optional (env (make-empty-environment)))
2004-11-17 mantoniotti 232 (loop for a in as
22:19:54 ' 233 for b across bs
' 234 for mgu = (unify a b env) then (unify a b mgu)
' 235 finally (return mgu)))
' 236
' 237
2009-12-17 mantoniotti 238 (defmethod untyped-unify ((as vector) (bs list)
16:44:46 ' 239 &optional (env (make-empty-environment)))
2004-11-17 mantoniotti 240 (untyped-unify bs as env))
22:19:54 ' 241
' 242 (defmethod untyped-unify ((a t) (b t) &optional (env (make-empty-environment)))
' 243 (unify a b env))
' 244
' 245
2009-04-15 mantoniotti 246 (defmethod unify ((as array) (bs array)
10:14:24 ' 247 &optional (env (make-empty-environment))
' 248 &key &allow-other-keys)
2004-11-17 mantoniotti 249 (unless (= (array-total-size as) (array-total-size bs))
22:19:54 ' 250 (error 'unification-failure
' 251 :format-control "Cannot unify two arrays of different total size: ~D and ~D."
' 252 :format-arguments (list (array-total-size as) (array-total-size bs))))
' 253 (loop for ai from 0 below (array-total-size as)
' 254 for bi from 0 below (array-total-size bs)
' 255 for mgu = (unify (row-major-aref as ai) (row-major-aref bs bi) env)
' 256 then (unify (row-major-aref as ai) (row-major-aref bs bi) mgu)
' 257 finally (return mgu)))
' 258
' 259
' 260 ;;; Catch all method.
' 261
2009-04-15 mantoniotti 262 (defmethod unify ((a t) (b t)
10:14:24 ' 263 &optional (env (make-empty-environment))
' 264 &key &allow-other-keys)
2004-11-17 mantoniotti 265 (if (equalp a b)
22:19:54 ' 266 env
' 267 (error 'unification-failure
' 268 :format-control "Cannot unify a ~S and a ~S: ~S ~S."
' 269 :format-arguments (list (type-of a) (type-of b) a b))))
' 270
' 271
' 272 ;;;===========================================================================
' 273 ;;; Templates methods.
' 274
' 275
' 276 ;;; valid-template-p --
' 277 ;;; Useful later. Tests whether the object X can be considered a template.
2005-01-28 mantoniotti 278 ;;; This should probably become a generic function.
2004-11-17 mantoniotti 279
22:19:54 ' 280 (defun valid-template-p (x)
' 281 (or (symbolp x)
' 282 (consp x)
' 283 (numberp x)
2005-01-28 mantoniotti 284 (arrayp x)
19:30:35 ' 285 (typep (class-of x) 'structure-class)
' 286 (typep (class-of x) 'standard-class)
' 287 (typep (class-of x) 'built-in-class)
2004-11-17 mantoniotti 288 (template-p x)))
22:19:54 ' 289
' 290
' 291 ;;; Special catch all method.
' 292
2009-04-15 mantoniotti 293 (defmethod unify ((x template) (y template)
10:14:24 ' 294 &optional (env)
' 295 &key &allow-other-keys)
2006-07-19 mantoniotti 296 (declare (ignore env))
2004-11-17 mantoniotti 297 (error 'unification-failure
2009-04-15 mantoniotti 298 :format-control "Unification of two templates of type ~A and ~A ~
10:14:24 ' 299 has not been yet implemented."
2004-11-17 mantoniotti 300 :format-arguments (list (class-name (class-of x))
22:19:54 ' 301 (class-name (class-of y)))))
' 302
' 303
' 304 ;;;---------------------------------------------------------------------------
' 305 ;;; NIL special unification methods.
' 306
2006-07-19 mantoniotti 307 (defmethod unify ((x null) (y null)
2009-04-15 mantoniotti 308 &optional (env (make-empty-environment))
10:14:24 ' 309 &key &allow-other-keys)
2006-07-19 mantoniotti 310 env)
21:52:34 ' 311
' 312
' 313 (defmethod unify ((x null) (nt nil-template)
2009-04-15 mantoniotti 314 &optional (env (make-empty-environment))
10:14:24 ' 315 &key &allow-other-keys)
2004-11-17 mantoniotti 316 env)
22:19:54 ' 317
' 318
2006-07-19 mantoniotti 319 (defmethod unify ((nt nil-template) (x null)
2009-04-15 mantoniotti 320 &optional (env (make-empty-environment))
10:14:24 ' 321 &key &allow-other-keys)
2004-11-17 mantoniotti 322 env)
22:19:54 ' 323
' 324
2006-07-19 mantoniotti 325 (defmethod unify ((nt1 nil-template) (nt2 nil-template)
2009-04-15 mantoniotti 326 &optional (env (make-empty-environment))
10:14:24 ' 327 &key &allow-other-keys)
2004-11-17 mantoniotti 328 env)
22:19:54 ' 329
' 330
' 331 ;;;---------------------------------------------------------------------------
' 332 ;;; Symbol methods.
' 333
2009-04-15 mantoniotti 334 (defmethod unify ((a symbol) (b symbol-template)
10:14:24 ' 335 &optional (env (make-empty-environment))
' 336 &key &allow-other-keys)
2004-11-17 mantoniotti 337 (cond ((variable-any-p a) env)
22:19:54 ' 338 ((variablep a) (var-unify a b env))
' 339 (t (unify a (symbol-template-symbol b) env))))
' 340
' 341
2009-04-15 mantoniotti 342 (defmethod unify ((b symbol-template) (a symbol)
10:14:24 ' 343 &optional (env (make-empty-environment))
' 344 &key &allow-other-keys)
2004-11-17 mantoniotti 345 (unify a b env))
22:19:54 ' 346
' 347
2009-04-15 mantoniotti 348 (defmethod unify ((a symbol) (b template)
10:14:24 ' 349 &optional (env)
' 350 &key &allow-other-keys)
2004-11-17 mantoniotti 351 (declare (ignore env))
22:19:54 ' 352 (error 'unification-failure
' 353 :format-control "Cannot unify symbol ~S with template ~S."
' 354 :format-arguments (list a b)))
' 355
2009-04-15 mantoniotti 356
10:14:24 ' 357 (defmethod unify ((b template) (a symbol)
' 358 &optional (env (make-empty-environment))
' 359 &key &allow-other-keys)
2004-11-17 mantoniotti 360 (unify a b env))
22:19:54 ' 361
' 362
' 363
' 364 ;;;---------------------------------------------------------------------------
' 365 ;;; Number template methods.
' 366
2009-04-15 mantoniotti 367 (defmethod unify ((a number) (b number-template)
10:14:24 ' 368 &optional (env (make-empty-environment))
' 369 &key &allow-other-keys)
2004-11-17 mantoniotti 370 (unify a (number-template-number b) env))
22:19:54 ' 371
' 372
2009-04-15 mantoniotti 373 (defmethod unify ((b number-template) (a number)
10:14:24 ' 374 &optional (env (make-empty-environment))
' 375 &key &allow-other-keys)
2004-11-17 mantoniotti 376 (unify a b env))
22:19:54 ' 377
2009-04-15 mantoniotti 378 (defmethod unify ((a number) (b template)
10:14:24 ' 379 &optional (env)
' 380 &key &allow-other-keys)
2004-11-17 mantoniotti 381 (declare (ignore env))
22:19:54 ' 382 (error 'unification-failure
' 383 :format-control "Cannot unify the number ~S with template ~S."
' 384 :format-arguments (list a b)))
' 385
2009-04-15 mantoniotti 386 (defmethod unify ((b template) (a number)
10:14:24 ' 387 &optional (env (make-empty-environment))
' 388 &key &allow-other-keys)
2004-11-17 mantoniotti 389 (unify a b env))
22:19:54 ' 390
' 391
' 392 ;;;---------------------------------------------------------------------------
' 393 ;;; Sequence (List) template methods
' 394
2009-04-15 mantoniotti 395 (defmethod unify ((a sequence) (b template)
10:14:24 ' 396 &optional (env)
' 397 &key &allow-other-keys)
2006-07-19 mantoniotti 398 (declare (ignore env))
2004-11-17 mantoniotti 399 (error 'unification-failure
2009-04-15 mantoniotti 400 :format-control "Cannot unify a sequence with a non sequence ~
10:14:24 ' 401 or non sequence access template: ~S and ~S."
2004-11-17 mantoniotti 402 :format-arguments (list a b)))
22:19:54 ' 403
' 404
2009-04-15 mantoniotti 405 (defmethod unify ((b template) (a sequence)
10:14:24 ' 406 &optional (env (make-empty-environment))
' 407 &key &allow-other-keys)
2004-11-17 mantoniotti 408 (unify a b env))
22:19:54 ' 409
' 410
2009-04-15 mantoniotti 411 #| Needs to be fixed.
10:14:24 ' 412 (defmethod unify ((a list) (b lambda-template) &optional (env (make-empty-environment)))
' 413 (unify a (template-spec b) env))
' 414
' 415
' 416 (defmethod unify ((b lambda-template) (a list) &optional (env (make-empty-environment)))
' 417 (unify (template-spec b) a env))
' 418 |#
' 419
' 420
2004-11-17 mantoniotti 421 ;;; The next is incomplete and does not signal appropriate errors.
22:19:54 ' 422
2009-04-15 mantoniotti 423 (defmethod unify ((a list) (b template)
10:14:24 ' 424 &optional (env)
' 425 &key &allow-other-keys)
2004-11-17 mantoniotti 426 (declare (ignore env))
22:19:54 ' 427 (error 'unification-failure
' 428 :format-control "Cannot unify a list with a non-list template: ~S ~S."
' 429 :format-arguments (list a b)))
' 430
' 431
2009-04-15 mantoniotti 432 (defmethod unify ((a list) (b sequence-template)
10:14:24 ' 433 &optional (env (make-empty-environment))
' 434 &key &allow-other-keys)
2004-11-17 mantoniotti 435 (let ((template-lambda-list (sequence-template-lambda-list b))
22:19:54 ' 436 (ll (list-length a))
' 437 )
' 438 (multiple-value-bind (vars optionals keys rest)
' 439 (parse-extended-ordinary-lambda-list template-lambda-list
' 440 :ordinary-variable-test #'valid-template-p
' 441 :optional-variable-test #'valid-template-p
' 442 :key-variable-test #'valid-template-p
' 443 :rest-variable-test #'valid-template-p
' 444 )
2011-04-02 rbrown 445
2004-11-17 mantoniotti 446 (let* ((n-vars (list-length vars))
22:19:54 ' 447 (n-optionals (list-length optionals))
2005-10-25 mantoniotti 448 (env (unify (subseq a 0 (min ll (list-length vars)))
19:17:33 ' 449 vars
' 450 env))
2004-11-17 mantoniotti 451 )
22:19:54 ' 452 (when (and optionals (>= ll (+ n-vars n-optionals)))
' 453 (setf env (unify (subseq a n-vars (+ n-vars n-optionals)) optionals env)))
' 454 (when (and rest (>= ll (+ n-vars n-optionals)))
' 455 (setf env (unify (subseq a (+ n-vars n-optionals)) (first rest) env)))
2009-12-17 mantoniotti 456 (when keys (warn "Sorry matching of keywords ~S not yet implemented." keys))
2004-11-17 mantoniotti 457 env
22:19:54 ' 458 ))))
' 459
' 460
' 461
2009-04-15 mantoniotti 462 (defmethod unify ((b template) (a list)
10:14:24 ' 463 &optional (env (make-empty-environment))
' 464 &key &allow-other-keys)
2004-11-17 mantoniotti 465 (unify a b env))
22:19:54 ' 466
' 467
' 468
' 469 ;;;---------------------------------------------------------------------------
' 470 ;;; Vector template methods.
' 471
2009-04-15 mantoniotti 472 (defmethod unify ((a vector) (b template)
10:14:24 ' 473 &optional (env)
' 474 &key &allow-other-keys)
2006-07-19 mantoniotti 475 (declare (ignore env))
2004-11-17 mantoniotti 476 (error 'unification-failure
22:19:54 ' 477 :format-control "Cannot unify a vector with a non-vector template: ~S ~S."
' 478 :format-arguments (list a b)))
' 479
' 480
2011-04-02 rbrown 481 (defmethod unify ((a vector) (b sequence-template)
2009-04-15 mantoniotti 482 &optional (env (make-empty-environment))
10:14:24 ' 483 &key &allow-other-keys)
2004-11-17 mantoniotti 484 (let ((template-lambda-list (sequence-template-lambda-list b))
22:19:54 ' 485 (vl (length a))
' 486 )
' 487 (multiple-value-bind (vars optionals keys rest)
' 488 (parse-extended-ordinary-lambda-list template-lambda-list
' 489 :ordinary-variable-test #'valid-template-p
' 490 :optional-variable-test #'valid-template-p
' 491 :key-variable-test #'valid-template-p
' 492 :rest-variable-test #'valid-template-p
' 493 )
2011-04-02 rbrown 494
2004-11-17 mantoniotti 495 (let ((n-vars (list-length vars))
22:19:54 ' 496 (n-optionals (list-length optionals))
' 497 )
' 498 (loop for v in vars
' 499 for e across (subseq a 0 (list-length vars))
' 500 for mgu = (unify v e env) then (unify v e mgu)
' 501 finally (setf env mgu))
' 502 (when (and optionals (>= vl (+ n-vars n-optionals)))
' 503 (loop for v in optionals
' 504 for e across (subseq a n-vars (+ n-vars n-optionals))
' 505 for mgu = (unify v e env) then (unify v e mgu)
' 506 finally (setf env mgu)))
' 507 (when (and rest (>= vl (+ n-vars n-optionals)))
' 508 (setf env (unify (subseq a (+ n-vars n-optionals)) (first rest) env)))
' 509 (when keys (warn "Sorry matching of keywords ~S not yet implemented." keys))
' 510 env
' 511 ))))
' 512
' 513
2009-04-15 mantoniotti 514 (defmethod unify ((b template) (a vector)
10:14:24 ' 515 &optional (env (make-empty-environment))
' 516 &key &allow-other-keys)
2004-11-17 mantoniotti 517 (unify a b env))
22:19:54 ' 518
' 519
' 520 ;;;---------------------------------------------------------------------------
' 521 ;;; Array template methods.
' 522
2009-04-15 mantoniotti 523 (defmethod unify ((a array) (b template)
10:14:24 ' 524 &optional (env)
' 525 &key &allow-other-keys)
2006-07-19 mantoniotti 526 (declare (ignore env))
2004-11-17 mantoniotti 527 (error 'unification-failure
2009-04-15 mantoniotti 528 :format-control "Cannot unify an array with a non array ~
10:14:24 ' 529 or non array access template: ~S and ~S."
2004-11-17 mantoniotti 530 :format-arguments (list a b)))
22:19:54 ' 531
2009-04-15 mantoniotti 532 (defmethod unify ((b template) (a array)
10:14:24 ' 533 &optional (env (make-empty-environment))
' 534 &key &allow-other-keys)
2004-11-17 mantoniotti 535 (unify a b env))
22:19:54 ' 536
' 537
' 538 (defun unify-array-row (array dims shape-template indexes env)
' 539 (cond ((null dims) env)
' 540 ((= (list-length dims) 1)
' 541 ;; Unify the row with the shape-template.
' 542 (let ((row (make-array (first dims)
' 543 :displaced-to array
' 544 :displaced-index-offset
2009-04-15 mantoniotti 545 (apply #'array-row-major-index
10:14:24 ' 546 array
' 547 (append indexes (list 0))))))
2004-11-17 mantoniotti 548 (declare (dynamic-extent row)
22:19:54 ' 549 (type array row))
' 550 (untyped-unify row shape-template env)))
' 551 (t
' 552 (loop for i from 0 below (first dims)
' 553 for row-template in shape-template
' 554 do (unify-array-row array
' 555 (rest dims)
' 556 row-template
' 557 (append indexes (list i))
' 558 env)
' 559 finally (return env)))
' 560 ))
' 561
' 562
' 563 (defun unify-array-rows (array shape-template env)
' 564 (unify-array-row array (array-dimensions array) shape-template () env))
' 565
' 566
2009-04-15 mantoniotti 567 (defmethod unify ((a array) (b array-template)
10:14:24 ' 568 &optional (env (make-empty-environment))
' 569 &key &allow-other-keys)
2004-11-17 mantoniotti 570 (let ((template-spec (template-spec b)))
22:19:54 ' 571 (if (= 2 (length template-spec))
' 572
' 573 ;; Template is (<array type specifier> <shape-template>)
' 574 (destructuring-bind (array-type-spec shape-template)
' 575 template-spec
' 576 (declare (ignore array-type-spec))
' 577 ;; Missing check for type-spec.
' 578 (unify-array-rows a shape-template env))
' 579
' 580 ;; Template is (array (['*' | <element type>] [<dimension spec>]) <shape template>)
' 581 (destructuring-bind (array-kwd type-spec shape-template)
' 582 template-spec
2006-07-19 mantoniotti 583 (declare (ignore array-kwd type-spec))
2004-11-17 mantoniotti 584 ;; Missing check for type-spec.
22:19:54 ' 585 (unify-array-rows a shape-template env))
' 586 )))
' 587
' 588
' 589
' 590 ;;;---------------------------------------------------------------------------
' 591 ;;; Standard object template methods.
' 592
2009-04-15 mantoniotti 593 (defmethod unify ((a standard-object) (b template)
10:14:24 ' 594 &optional (env)
' 595 &key &allow-other-keys)
2006-07-19 mantoniotti 596 (declare (ignore env))
2004-11-17 mantoniotti 597 (error 'unification-failure
2009-04-15 mantoniotti 598 :format-control "Cannot unify a standard object with a ~
10:14:24 ' 599 non standard object template: ~S and ~S."
2004-11-17 mantoniotti 600 :format-arguments (list a b)))
22:19:54 ' 601
2006-07-19 mantoniotti 602 #|| Old version with heavy syntax
2004-11-17 mantoniotti 603 (defmethod unify ((a standard-object) (b standard-object-template)
22:19:54 ' 604 &optional (env (make-empty-environment)))
' 605 (destructuring-bind (class &rest template-slot-specs)
' 606 (template-spec b)
' 607 (unless (typep a class)
' 608 (error 'unification-failure
' 609 :format-control "Cannot unify an instance of ~S with a template for class ~S."
' 610 :format-arguments (list (class-of a) class)))
' 611 (flet ((slot-spec-unify (accessor-spec reader value-template mgu)
' 612 (ecase accessor-spec
' 613 (slot-value
' 614 (unify (slot-value a reader) value-template mgu))
' 615 (slot-accessor
' 616 (unify (funcall reader a) value-template mgu))))
' 617 )
' 618 (if template-slot-specs
' 619 (loop for (accessor-spec reader value-template) in template-slot-specs
' 620 for mgu = (slot-spec-unify accessor-spec reader value-template env)
' 621 then (slot-spec-unify accessor-spec reader value-template mgu)
' 622 finally (return mgu))
' 623 env))))
2006-07-19 mantoniotti 624 ||#
2004-11-17 mantoniotti 625
22:19:54 ' 626
' 627 (defmethod unify ((a standard-object) (b standard-object-template)
2009-04-15 mantoniotti 628 &optional (env (make-empty-environment))
10:14:24 ' 629 &key &allow-other-keys)
2004-11-17 mantoniotti 630 (destructuring-bind (class &rest template-slot-specs)
22:19:54 ' 631 (template-spec b)
' 632 (unless (typep a class)
' 633 (error 'unification-failure
' 634 :format-control "Cannot unify an instance of ~S with a template for class ~S."
' 635 :format-arguments (list (class-of a) class)))
' 636 (flet ((slot-spec-unify (reader value-template mgu)
' 637 (etypecase reader
' 638 (list
' 639 (assert (eq (first reader) 'slot-value))
' 640 (unify (slot-value a (second reader)) value-template mgu))
' 641 ((or function symbol)
' 642 (unify (funcall reader a) value-template mgu))))
' 643 )
' 644 (if template-slot-specs
' 645 (loop for (reader value-template) on template-slot-specs by #'cddr
' 646 for mgu = (slot-spec-unify reader value-template env)
' 647 then (slot-spec-unify reader value-template mgu)
' 648 finally (return mgu))
' 649 env))))
' 650
' 651
2009-04-15 mantoniotti 652 (defmethod unify ((b template) (a standard-object)
10:14:24 ' 653 &optional (env (make-empty-environment))
' 654 &key &allow-other-keys)
2004-11-17 mantoniotti 655 (unify a b env))
22:19:54 ' 656
' 657
' 658 ;;;---------------------------------------------------------------------------
' 659 ;;; Structure object template methods.
' 660
2009-04-15 mantoniotti 661 (defmethod unify ((a structure-object) (b template)
10:14:24 ' 662 &optional (env)
' 663 &key &allow-other-keys)
2006-07-19 mantoniotti 664 (declare (ignore env))
2004-11-17 mantoniotti 665 (error 'unification-failure
2009-04-15 mantoniotti 666 :format-control "Cannot unify a structure object with ~
10:14:24 ' 667 a non structure object template: ~S and ~S."
2004-11-17 mantoniotti 668 :format-arguments (list a b)))
22:19:54 ' 669
' 670
' 671 (defmethod unify ((a structure-object) (b structure-object-template)
2009-04-15 mantoniotti 672 &optional (env (make-empty-environment))
10:14:24 ' 673 &key &allow-other-keys)
2004-11-17 mantoniotti 674 (destructuring-bind (class &rest template-slot-specs)
22:19:54 ' 675 (template-spec b)
' 676 (unless (typep a class)
' 677 (error 'unification-failure
2009-04-15 mantoniotti 678 :format-control "Cannot unify an instance of ~S with a ~
10:14:24 ' 679 template for structure ~S."
2004-11-17 mantoniotti 680 :format-arguments (list (class-of a) class)))
22:19:54 ' 681 (if template-slot-specs
' 682 (loop for (reader value-template) on template-slot-specs by #'cddr
' 683 for mgu = (unify (funcall reader a) value-template env)
' 684 then (unify (funcall reader a) value-template mgu)
' 685 finally (return mgu))
' 686 env)))
' 687
' 688
2009-04-15 mantoniotti 689 (defmethod unify ((b template) (a structure-object)
10:14:24 ' 690 &optional (env (make-empty-environment))
' 691 &key &allow-other-keys)
2004-11-17 mantoniotti 692 (unify a b env))
22:19:54 ' 693
' 694
' 695 ;;;---------------------------------------------------------------------------
' 696 ;;; Expression template SUBSEQ methods.
' 697
2009-04-15 mantoniotti 698 ;;; SEQUENCE
10:14:24 ' 699 ;;; For non LIST and non VECTOR possible SEQUENCE types.
' 700
' 701 (defmethod unify ((a sequence) (b subseq-template)
' 702 &optional (env (make-empty-environment))
' 703 &key &allow-other-keys)
2004-11-17 mantoniotti 704 (destructuring-bind (subseq-kwd from to &rest spec)
22:19:54 ' 705 (template-spec b)
2009-04-15 mantoniotti 706 (declare (ignore subseq-kwd))
2004-11-17 mantoniotti 707 (let* ((seq-type (type-of a))
2009-04-15 mantoniotti 708 (seq-template-kind (if (symbolp seq-type)
10:14:24 ' 709 seq-type
' 710 (first seq-type))) ; Stupid FTTB.
2004-11-17 mantoniotti 711 )
2009-04-15 mantoniotti 712 (unify (subseq a from to)
10:14:24 ' 713 (make-template seq-template-kind `(,seq-template-kind ,@spec))
' 714 env))))
' 715
' 716
' 717 ;;; LIST
' 718
' 719 (defmethod unify ((a list) (b subseq-template)
' 720 &optional (env (make-empty-environment))
' 721 &key &allow-other-keys)
' 722 (destructuring-bind (subseq-kwd from to &rest spec)
' 723 (template-spec b)
' 724 (declare (ignore subseq-kwd))
2006-07-19 mantoniotti 725 (unify (subseq a from to)
2009-04-15 mantoniotti 726 (make-template 'list `(list ,@spec))
10:14:24 ' 727 env)))
' 728
' 729
' 730 ;;; VECTOR
' 731
' 732 (defmethod unify ((a vector) (b subseq-template)
' 733 &optional (env (make-empty-environment))
' 734 &key &allow-other-keys)
' 735 (destructuring-bind (subseq-kwd from to &rest spec)
' 736 (template-spec b)
' 737 (declare (ignore subseq-kwd))
' 738 (let ((seq-type (type-of a)))
' 739 (unify (subseq a from to)
' 740 (make-template seq-type `(,seq-type ,@spec))
' 741 env))))
2004-11-17 mantoniotti 742
22:19:54 ' 743
2009-04-15 mantoniotti 744 (defmethod unify ((b subseq-template) (a sequence)
10:14:24 ' 745 &optional (env (make-empty-environment))
' 746 &key &allow-other-keys)
2004-11-17 mantoniotti 747 (unify a b env))
22:19:54 ' 748
' 749
' 750 ;;;---------------------------------------------------------------------------
2009-04-15 mantoniotti 751 ;;; Expression templates
2004-11-17 mantoniotti 752
2009-04-15 mantoniotti 753 ;;; AREF methods.
10:14:24 ' 754
' 755 (defmethod unify ((a array) (b aref-template)
' 756 &optional (env (make-empty-environment))
' 757 &key &allow-other-keys)
2004-11-17 mantoniotti 758 (destructuring-bind (aref-kwd indexes value-template)
22:19:54 ' 759 (template-spec b)
' 760 (declare (ignore aref-kwd))
' 761 ;; Missing check on index spec.
' 762 (unless (consp indexes)
' 763 (setf indexes (list indexes)))
' 764 (unify (apply #'aref a indexes) value-template env)))
' 765
' 766
2009-04-15 mantoniotti 767 ;;; Necessary due to standard method sorting.
10:14:24 ' 768
' 769 (defmethod unify ((a vector) (b aref-template)
' 770 &optional (env (make-empty-environment))
' 771 &key &allow-other-keys)
' 772 (destructuring-bind (aref-kwd indexes value-template)
' 773 (template-spec b)
' 774 (declare (ignore aref-kwd))
' 775 ;; Missing check on index spec.
' 776 (when (and (consp indexes) (> (length indexes) 1))
' 777 (error 'unification-failure
' 778 :format-control "Cannot unify a vector with an element ~
' 779 too many dimensions down~@
' 780 (AREF #(...)~{ ~S~})."
' 781 :format-arguments (list indexes)
' 782 ))
' 783 (unless (consp indexes)
' 784 (setf indexes (list indexes)))
' 785 (unify (apply #'aref a indexes) value-template env)))
' 786
' 787
' 788 (defmethod unify ((b aref-template) (a array)
' 789 &optional (env (make-empty-environment))
' 790 &key &allow-other-keys)
' 791 (unify a b env))
' 792
' 793
' 794 ;;; ELT methods.
' 795 ;;; LIST and VECTOR methods must be specified separatedly because of
' 796 ;;; the UNIFY (VECTOR TEMPLATE) methods above. It is a snag, but a
' 797 ;;; relatively small one. Besides, they are more efficient.
' 798 ;;; The (SEQUENCE ELT-TEMPLATE) ELT-TEMPLATE method is left for those
' 799 ;;; sequences which, according to the ANSI spec may exist and not be
' 800 ;;; either VECTOR or LIST.
' 801
' 802 (defmethod unify ((a sequence) (b elt-template)
' 803 &optional (env (make-empty-environment))
' 804 &key &allow-other-keys)
' 805 (destructuring-bind (elt-kwd index value-template)
' 806 (template-spec b)
' 807 (declare (ignore elt-kwd)
' 808 (type fixnum index))
' 809 ;; Missing index check.
' 810 (unify (elt a index) value-template env)))
' 811
' 812
' 813 (defmethod unify ((a vector) (b elt-template)
' 814 &optional (env (make-empty-environment))
' 815 &key &allow-other-keys)
' 816 (destructuring-bind (elt-kwd index value-template)
' 817 (template-spec b)
' 818 (declare (ignore elt-kwd)
' 819 (type fixnum index))
' 820 ;; Missing index check.
' 821 (unify (aref a index) value-template env)))
' 822
' 823
' 824 (defmethod unify ((a list) (b elt-template)
' 825 &optional (env (make-empty-environment))
' 826 &key &allow-other-keys)
' 827 (destructuring-bind (elt-kwd index value-template)
' 828 (template-spec b)
' 829 (declare (ignore elt-kwd)
' 830 (type fixnum index))
' 831 ;; Missing index check.
' 832 (unify (nth index a) value-template env)))
' 833
' 834
' 835 (defmethod unify ((b elt-template) (a sequence)
' 836 &optional (env (make-empty-environment))
' 837 &key &allow-other-keys)
' 838 (unify a b env))
' 839
' 840
' 841 ;;; NTH methods.
' 842
' 843 (defmethod unify ((a list) (b nth-template)
' 844 &optional (env (make-empty-environment))
' 845 &key &allow-other-keys)
' 846 (destructuring-bind (nth-kwd index value-template)
' 847 (template-spec b)
' 848 (declare (ignore nth-kwd))
' 849 ;; Missing index check.
' 850 (unify (nth index a) value-template env)))
' 851
' 852 (defmethod unify ((b nth-template) (a list)
' 853 &optional (env (make-empty-environment))
' 854 &key &allow-other-keys)
' 855 (unify a b env))
' 856
' 857
' 858 ;;;---------------------------------------------------------------------------
' 859 ;;; Utilities.
' 860
' 861 (defun unify* (a b &optional (env (make-empty-environment)))
2010-01-15 pix 862 (handler-case
07:59:02 ' 863 (unify a b env)
' 864 (unification-failure (c) (values nil c))))
' 865
2009-04-15 mantoniotti 866
10:14:24 ' 867 (defun unify-equations (eqns &optional (env (make-empty-environment)))
' 868 (loop for (a b) in eqns
' 869 for result-env = (unify a b env) then (unify a b result-env)
' 870 finally (return result-env)))
' 871
' 872
' 873 (defun unify-equations* (lhss rhss &optional (env (make-empty-environment)))
' 874 (loop for a in lhss
' 875 for b in rhss
' 876 for result-env = (unify a b env) then (unify a b result-env)
' 877 finally (return result-env)))
' 878
' 879
2004-11-17 mantoniotti 880 ;;;---------------------------------------------------------------------------
22:19:54 ' 881 ;;; VAR-UNIFY
' 882
' 883 (defparameter *occurrence-check-p* t)
' 884
' 885 (defgeneric occurs-in-p (var pat env))
' 886
' 887 (defun var-unify (var pat env)
' 888 (if (eq var pat)
' 889 env
' 890 (multiple-value-bind (value foundp)
' 891 (find-variable-value var env)
' 892 (cond (foundp
' 893 (unify value pat env))
' 894 ((and *occurrence-check-p*
' 895 (occurs-in-p var pat env))
' 896 (error 'unification-failure
' 897 :format-control "Variable ~S occurs in ~S."
' 898 :format-arguments (list var pat)))
' 899 (t
' 900 (extend-environment var pat env))))))
' 901
' 902
' 903
2006-07-19 mantoniotti 904 #||
2004-11-17 mantoniotti 905 (defmethod occurs-in-p ((var symbol) pat env)
22:19:54 ' 906 (cond ((variablep pat)
' 907 (or (eq var pat)
' 908 (multiple-value-bind (value foundp)
' 909 (find-variable-value pat env)
' 910 (when foundp
' 911 (occurs-in-p var value env)))
' 912 ))
' 913 ((atom pat) nil)
' 914 ((consp pat)
' 915 (or (occurs-in-p var (first pat) env)
' 916 (occurs-in-p var (rest pat) env)))
' 917 (t
' 918 (error "unimplemented"))))
2006-07-19 mantoniotti 919 ||#
21:52:34 ' 920
2004-11-17 mantoniotti 921
22:19:54 ' 922 (defmethod occurs-in-p ((var symbol) (pat symbol) env)
' 923 (when (variablep pat)
' 924 (or (eq var pat)
' 925 (multiple-value-bind (value foundp)
' 926 (find-variable-value pat env)
' 927 (when foundp
' 928 (occurs-in-p var value env)))
' 929 )))
' 930
2006-07-19 mantoniotti 931
2004-11-17 mantoniotti 932 (defmethod occurs-in-p ((var symbol) (pat list) env)
22:19:54 ' 933 (or (occurs-in-p var (first pat) env)
' 934 (occurs-in-p var (rest pat) env)))
' 935
2006-07-19 mantoniotti 936
21:52:34 ' 937 (defmethod occurs-in-p ((var symbol) (pat null) env)
' 938 ;; This is needed because of different precedence rules among lisps
' 939 ;; in COMPUTE-APPLICABLE-METHODS when NIL has to matched against
' 940 ;; SYMBOL and LIST.
2011-04-02 rbrown 941
2006-07-19 mantoniotti 942 ;; We know (assume) that VAR is not NIL.
21:52:34 ' 943 nil)
' 944
' 945
2004-11-17 mantoniotti 946 (defmethod occurs-in-p ((var symbol) (pat array) env)
22:19:54 ' 947 (loop for i from 0 below (array-total-size pat)
' 948 thereis (occurs-in-p var (row-major-aref pat i) env)))
' 949
' 950
' 951 (defmethod occurs-in-p ((var symbol) (pat vector) env) ; This may be faster than the above.
' 952 (some #'(lambda (x) (occurs-in-p var x env)) pat))
' 953
' 954
' 955 (defmethod occurs-in-p ((var symbol) (pat string) env) ; This is useless, but it's here for completeness.
' 956 (declare (ignore env))
' 957 nil)
' 958
' 959
' 960 (defmethod occurs-in-p ((var symbol) (pat number) env)
' 961 (declare (ignore env))
' 962 nil)
' 963
' 964
2009-04-15 mantoniotti 965 (defmethod occurs-in-p ((var symbol) (pat character) env)
10:14:24 ' 966 (declare (ignore env))
' 967 nil)
' 968
' 969
2004-11-17 mantoniotti 970 (defmethod occurs-in-p ((var symbol) (pat t) env)
22:19:54 ' 971 (declare (ignore env))
2009-04-15 mantoniotti 972 (warn "Occurrence test unimplemented for pattern ~S of type ~S in variable ~S;~@
10:14:24 ' 973 returning false."
2004-11-17 mantoniotti 974 pat
2009-04-15 mantoniotti 975 (type-of pat)
10:14:24 ' 976 var)
2004-11-17 mantoniotti 977 nil)
22:19:54 ' 978
' 979
' 980 (defmethod occurs-in-p ((var t) (pat t) env)
' 981 (declare (ignore env))
' 982 (error "Occurrence test called on a non symbol ~S. Major problem."
' 983 var))
' 984
' 985 ;;; end of file -- unifier.lisp --
Sally sells sea-shells by the sea shore.