1 ;;; -*- Mode: Lisp -*- 2 3 ;;; unifier.lisp 4 ;;; General CL structures unifier. 5 6 ;;;; See file COPYING for copyright licensing information. 7 8 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow. 9 10 (defgeneric unify (a b &optional env &key &allow-other-keys) 11 (:documentation 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 27 (defmethod unify ((a symbol) (b list) 28 &optional (env (make-empty-environment)) 29 &key &allow-other-keys) 30 "Unifies a symbol A and a list B in an environment ENV. 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 42 (defmethod unify ((b list) (a symbol) 43 &optional (env (make-empty-environment)) 44 &key &allow-other-keys) 45 "Unifies a symbol B and a list A in an environment ENV. 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 57 (defmethod unify ((a list) (b list) 58 &optional (env (make-empty-environment)) 59 &key &allow-other-keys) 60 "Unifies a list A and a list B in an environment ENV. 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 69 (defmethod unify ((a number) (b number) 70 &optional (env (make-empty-environment)) 71 &key &allow-other-keys) 72 "Unifies two numbers A and B. 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 85 (defparameter *unify-string-case-sensitive-p* t) 86 87 (defmethod unify ((a character) (b character) 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 96 *UNIFY-STRING-CASE-SENSITIVE-P*, which defaults to T. 97 If A and B unify then an unmodified environment ENV is returned, 98 otherwise an error of type UNIFICATION-FAILURE is signaled." 99 (cond ((and case-sensitive (char= a b)) 100 env) 101 ((and (not case-sensitive) (char-equal a b)) 102 env) 103 (t 104 (error 'unification-failure 105 :format-control "Cannot unify two different characters: ~S ~S." 106 :format-arguments (list a b))))) 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) 114 "Unifies two strings A and B. 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 118 *UNIFY-STRING-CASE-SENSITIVE-P*, which defaults to T. 119 If A and B unify then an unmodified environment ENV is returned, 120 otherwise an error of type UNIFICATION-FAILURE is signaled." 121 (cond ((and case-sensitive (string= a b)) 122 env) 123 ((and (not case-sensitive) (string-equal a b)) 124 env) 125 (t 126 (error 'unification-failure 127 :format-control "Cannot unify two different strings: ~S ~S." 128 :format-arguments (list a b))))) 129 130 131 (defmethod unify ((a symbol) (b string) 132 &optional (env (make-empty-environment)) 133 &key &allow-other-keys) 134 (cond ((variable-any-p a) env) 135 ((variablep a) (var-unify a b env)) 136 (t (error 'unification-failure 137 :format-control "Cannot unify a symbol with a string: ~S ~S." 138 :format-arguments (list a b))))) 139 140 141 (defmethod unify ((b string) (a symbol) 142 &optional (env (make-empty-environment)) 143 &key &allow-other-keys) 144 (cond ((variable-any-p a) env) 145 ((variablep a) (var-unify a b env)) 146 (t (error 'unification-failure 147 :format-control "Cannot unify a string with a symbol: ~S ~S." 148 :format-arguments (list b a))))) 149 150 151 (defmethod unify ((a symbol) (b symbol) 152 &optional (env (make-empty-environment)) 153 &key &allow-other-keys) 154 (cond ((variable-any-p a) env) 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 164 (defmethod unify ((a symbol) (b t) 165 &optional (env (make-empty-environment)) 166 &key &allow-other-keys) 167 (cond ((variable-any-p a) env) 168 ((variablep a) (var-unify a b env)) 169 (t (call-next-method)))) 170 171 172 (defmethod unify ((b t) (a symbol) 173 &optional (env (make-empty-environment)) 174 &key &allow-other-keys) 175 (cond ((variable-any-p a) env) 176 ((variablep a) (var-unify a b env)) 177 (t (call-next-method)))) 178 179 180 (defmethod unify ((a symbol) (b array) 181 &optional (env (make-empty-environment)) 182 &key &allow-other-keys) 183 (cond ((variable-any-p a) env) 184 ((variablep a) (var-unify a b env)) 185 (t (error 'unification-failure 186 :format-control "Cannot unify a symbol with ~ 187 an array or vector: ~S and ~S." 188 :format-arguments (list a b))))) 189 190 191 (defmethod unify ((b array) (a symbol) 192 &optional (env (make-empty-environment)) 193 &key &allow-other-keys) 194 (cond ((variable-any-p a) env) 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 201 (defmethod unify ((as vector) (bs vector) 202 &optional (env (make-empty-environment)) 203 &key &allow-other-keys) 204 (unless (= (length as) (length bs)) 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 214 (defmethod unify ((s1 sequence) (s2 sequence) 215 &optional (env (make-empty-environment)) 216 &key &allow-other-keys) 217 (unless (= (length s1) (length s2)) 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 230 (defmethod untyped-unify ((as list) (bs vector) 231 &optional (env (make-empty-environment))) 232 (loop for a in as 233 for b across bs 234 for mgu = (unify a b env) then (unify a b mgu) 235 finally (return mgu))) 236 237 238 (defmethod untyped-unify ((as vector) (bs list) 239 &optional (env (make-empty-environment))) 240 (untyped-unify bs as env)) 241 242 (defmethod untyped-unify ((a t) (b t) &optional (env (make-empty-environment))) 243 (unify a b env)) 244 245 246 (defmethod unify ((as array) (bs array) 247 &optional (env (make-empty-environment)) 248 &key &allow-other-keys) 249 (unless (= (array-total-size as) (array-total-size bs)) 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 262 (defmethod unify ((a t) (b t) 263 &optional (env (make-empty-environment)) 264 &key &allow-other-keys) 265 (if (equalp a b) 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. 278 ;;; This should probably become a generic function. 279 280 (defun valid-template-p (x) 281 (or (symbolp x) 282 (consp x) 283 (numberp x) 284 (arrayp x) 285 (typep (class-of x) 'structure-class) 286 (typep (class-of x) 'standard-class) 287 (typep (class-of x) 'built-in-class) 288 (template-p x))) 289 290 291 ;;; Special catch all method. 292 293 (defmethod unify ((x template) (y template) 294 &optional (env) 295 &key &allow-other-keys) 296 (declare (ignore env)) 297 (error 'unification-failure 298 :format-control "Unification of two templates of type ~A and ~A ~ 299 has not been yet implemented." 300 :format-arguments (list (class-name (class-of x)) 301 (class-name (class-of y))))) 302 303 304 ;;;--------------------------------------------------------------------------- 305 ;;; NIL special unification methods. 306 307 (defmethod unify ((x null) (y null) 308 &optional (env (make-empty-environment)) 309 &key &allow-other-keys) 310 env) 311 312 313 (defmethod unify ((x null) (nt nil-template) 314 &optional (env (make-empty-environment)) 315 &key &allow-other-keys) 316 env) 317 318 319 (defmethod unify ((nt nil-template) (x null) 320 &optional (env (make-empty-environment)) 321 &key &allow-other-keys) 322 env) 323 324 325 (defmethod unify ((nt1 nil-template) (nt2 nil-template) 326 &optional (env (make-empty-environment)) 327 &key &allow-other-keys) 328 env) 329 330 331 ;;;--------------------------------------------------------------------------- 332 ;;; Symbol methods. 333 334 (defmethod unify ((a symbol) (b symbol-template) 335 &optional (env (make-empty-environment)) 336 &key &allow-other-keys) 337 (cond ((variable-any-p a) env) 338 ((variablep a) (var-unify a b env)) 339 (t (unify a (symbol-template-symbol b) env)))) 340 341 342 (defmethod unify ((b symbol-template) (a symbol) 343 &optional (env (make-empty-environment)) 344 &key &allow-other-keys) 345 (unify a b env)) 346 347 348 (defmethod unify ((a symbol) (b template) 349 &optional (env) 350 &key &allow-other-keys) 351 (declare (ignore env)) 352 (error 'unification-failure 353 :format-control "Cannot unify symbol ~S with template ~S." 354 :format-arguments (list a b))) 355 356 357 (defmethod unify ((b template) (a symbol) 358 &optional (env (make-empty-environment)) 359 &key &allow-other-keys) 360 (unify a b env)) 361 362 363 364 ;;;--------------------------------------------------------------------------- 365 ;;; Number template methods. 366 367 (defmethod unify ((a number) (b number-template) 368 &optional (env (make-empty-environment)) 369 &key &allow-other-keys) 370 (unify a (number-template-number b) env)) 371 372 373 (defmethod unify ((b number-template) (a number) 374 &optional (env (make-empty-environment)) 375 &key &allow-other-keys) 376 (unify a b env)) 377 378 (defmethod unify ((a number) (b template) 379 &optional (env) 380 &key &allow-other-keys) 381 (declare (ignore env)) 382 (error 'unification-failure 383 :format-control "Cannot unify the number ~S with template ~S." 384 :format-arguments (list a b))) 385 386 (defmethod unify ((b template) (a number) 387 &optional (env (make-empty-environment)) 388 &key &allow-other-keys) 389 (unify a b env)) 390 391 392 ;;;--------------------------------------------------------------------------- 393 ;;; Sequence (List) template methods 394 395 (defmethod unify ((a sequence) (b template) 396 &optional (env) 397 &key &allow-other-keys) 398 (declare (ignore env)) 399 (error 'unification-failure 400 :format-control "Cannot unify a sequence with a non sequence ~ 401 or non sequence access template: ~S and ~S." 402 :format-arguments (list a b))) 403 404 405 (defmethod unify ((b template) (a sequence) 406 &optional (env (make-empty-environment)) 407 &key &allow-other-keys) 408 (unify a b env)) 409 410 411 #| Needs to be fixed. 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 421 ;;; The next is incomplete and does not signal appropriate errors. 422 423 (defmethod unify ((a list) (b template) 424 &optional (env) 425 &key &allow-other-keys) 426 (declare (ignore env)) 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 432 (defmethod unify ((a list) (b sequence-template) 433 &optional (env (make-empty-environment)) 434 &key &allow-other-keys) 435 (let ((template-lambda-list (sequence-template-lambda-list b)) 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 ) 445 446 (let* ((n-vars (list-length vars)) 447 (n-optionals (list-length optionals)) 448 (env (unify (subseq a 0 (min ll (list-length vars))) 449 vars 450 env)) 451 ) 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))) 456 (when keys (warn "Sorry matching of keywords ~S not yet implemented." keys)) 457 env 458 )))) 459 460 461 462 (defmethod unify ((b template) (a list) 463 &optional (env (make-empty-environment)) 464 &key &allow-other-keys) 465 (unify a b env)) 466 467 468 469 ;;;--------------------------------------------------------------------------- 470 ;;; Vector template methods. 471 472 (defmethod unify ((a vector) (b template) 473 &optional (env) 474 &key &allow-other-keys) 475 (declare (ignore env)) 476 (error 'unification-failure 477 :format-control "Cannot unify a vector with a non-vector template: ~S ~S." 478 :format-arguments (list a b))) 479 480 481 (defmethod unify ((a vector) (b sequence-template) 482 &optional (env (make-empty-environment)) 483 &key &allow-other-keys) 484 (let ((template-lambda-list (sequence-template-lambda-list b)) 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 ) 494 495 (let ((n-vars (list-length vars)) 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 514 (defmethod unify ((b template) (a vector) 515 &optional (env (make-empty-environment)) 516 &key &allow-other-keys) 517 (unify a b env)) 518 519 520 ;;;--------------------------------------------------------------------------- 521 ;;; Array template methods. 522 523 (defmethod unify ((a array) (b template) 524 &optional (env) 525 &key &allow-other-keys) 526 (declare (ignore env)) 527 (error 'unification-failure 528 :format-control "Cannot unify an array with a non array ~ 529 or non array access template: ~S and ~S." 530 :format-arguments (list a b))) 531 532 (defmethod unify ((b template) (a array) 533 &optional (env (make-empty-environment)) 534 &key &allow-other-keys) 535 (unify a b env)) 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 545 (apply #'array-row-major-index 546 array 547 (append indexes (list 0)))))) 548 (declare (dynamic-extent row) 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 567 (defmethod unify ((a array) (b array-template) 568 &optional (env (make-empty-environment)) 569 &key &allow-other-keys) 570 (let ((template-spec (template-spec b))) 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 583 (declare (ignore array-kwd type-spec)) 584 ;; Missing check for type-spec. 585 (unify-array-rows a shape-template env)) 586 ))) 587 588 589 590 ;;;--------------------------------------------------------------------------- 591 ;;; Standard object template methods. 592 593 (defmethod unify ((a standard-object) (b template) 594 &optional (env) 595 &key &allow-other-keys) 596 (declare (ignore env)) 597 (error 'unification-failure 598 :format-control "Cannot unify a standard object with a ~ 599 non standard object template: ~S and ~S." 600 :format-arguments (list a b))) 601 602 #|| Old version with heavy syntax 603 (defmethod unify ((a standard-object) (b standard-object-template) 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)))) 624 ||# 625 626 627 (defmethod unify ((a standard-object) (b standard-object-template) 628 &optional (env (make-empty-environment)) 629 &key &allow-other-keys) 630 (destructuring-bind (class &rest template-slot-specs) 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 652 (defmethod unify ((b template) (a standard-object) 653 &optional (env (make-empty-environment)) 654 &key &allow-other-keys) 655 (unify a b env)) 656 657 658 ;;;--------------------------------------------------------------------------- 659 ;;; Structure object template methods. 660 661 (defmethod unify ((a structure-object) (b template) 662 &optional (env) 663 &key &allow-other-keys) 664 (declare (ignore env)) 665 (error 'unification-failure 666 :format-control "Cannot unify a structure object with ~ 667 a non structure object template: ~S and ~S." 668 :format-arguments (list a b))) 669 670 671 (defmethod unify ((a structure-object) (b structure-object-template) 672 &optional (env (make-empty-environment)) 673 &key &allow-other-keys) 674 (destructuring-bind (class &rest template-slot-specs) 675 (template-spec b) 676 (unless (typep a class) 677 (error 'unification-failure 678 :format-control "Cannot unify an instance of ~S with a ~ 679 template for structure ~S." 680 :format-arguments (list (class-of a) class))) 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 689 (defmethod unify ((b template) (a structure-object) 690 &optional (env (make-empty-environment)) 691 &key &allow-other-keys) 692 (unify a b env)) 693 694 695 ;;;--------------------------------------------------------------------------- 696 ;;; Expression template SUBSEQ methods. 697 698 ;;; SEQUENCE 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) 704 (destructuring-bind (subseq-kwd from to &rest spec) 705 (template-spec b) 706 (declare (ignore subseq-kwd)) 707 (let* ((seq-type (type-of a)) 708 (seq-template-kind (if (symbolp seq-type) 709 seq-type 710 (first seq-type))) ; Stupid FTTB. 711 ) 712 (unify (subseq a from to) 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)) 725 (unify (subseq a from to) 726 (make-template 'list `(list ,@spec)) 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)))) 742 743 744 (defmethod unify ((b subseq-template) (a sequence) 745 &optional (env (make-empty-environment)) 746 &key &allow-other-keys) 747 (unify a b env)) 748 749 750 ;;;--------------------------------------------------------------------------- 751 ;;; Expression templates 752 753 ;;; AREF methods. 754 755 (defmethod unify ((a array) (b aref-template) 756 &optional (env (make-empty-environment)) 757 &key &allow-other-keys) 758 (destructuring-bind (aref-kwd indexes value-template) 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 767 ;;; Necessary due to standard method sorting. 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))) 862 (handler-case 863 (unify a b env) 864 (unification-failure (c) (values nil c)))) 865 866 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 880 ;;;--------------------------------------------------------------------------- 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 904 #|| 905 (defmethod occurs-in-p ((var symbol) pat env) 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")))) 919 ||# 920 921 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 931 932 (defmethod occurs-in-p ((var symbol) (pat list) env) 933 (or (occurs-in-p var (first pat) env) 934 (occurs-in-p var (rest pat) env))) 935 936 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. 941 942 ;; We know (assume) that VAR is not NIL. 943 nil) 944 945 946 (defmethod occurs-in-p ((var symbol) (pat array) env) 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 965 (defmethod occurs-in-p ((var symbol) (pat character) env) 966 (declare (ignore env)) 967 nil) 968 969 970 (defmethod occurs-in-p ((var symbol) (pat t) env) 971 (declare (ignore env)) 972 (warn "Occurrence test unimplemented for pattern ~S of type ~S in variable ~S;~@ 973 returning false." 974 pat 975 (type-of pat) 976 var) 977 nil) 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 --