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