1 ;;;; -*- Mode: Lisp -*- 2 3 ;;;; templates-hierarchy.lisp -- 4 5 ;;;; See file COPYING for copyright licensing information. 6 7 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow. 8 9 ;;; Templates. 10 ;;; Essentially we extend the type specifier language. 11 ;;; The interesting thing is that we need to specify how a "match" 12 ;;; between a template and a CL object is performed. 13 14 ;;; A template is one of the following 15 ;;; 16 ;;; <template> ::= <logical variable> 17 ;;; | <structure template> 18 ;;; | <instance template> 19 ;;; | <destructuring template> 20 ;;; | <vector template> 21 ;;; | <sequence template> 22 ;;; | <array template> 23 ;;; | <type template> 24 ;;; | <lisp object> 25 ;;; 26 27 ;;; Destructuring Template Lambda List (as per standard CL terminology) 28 ;;; 29 ;;; <destructuring template lambda list> ::= <a "destructuring LL" with <template> in lieu of <var>> 30 31 ;;; Templates for Structures and Instances 32 ;;; 33 ;;; <structure template> ::= (<class designator> <structure-slot-spec>*) 34 ;;; 35 ;;; <instance template> ::= (<class designator> <slot-spec>*) 36 ;;; 37 ;;; where 38 ;;; 39 ;;; <structure-slot-spec> ::= <reader-name> <template> 40 ;;; <instance-slot-spec> ::= <accessor-name> <template> 41 ;;; | (slot-value <slot-name>) <template> 42 43 ;;; Template for Sequences 44 ;;; 45 ;;; <sequence template> ::= (<container type> . <destructuring template lambda list>) 46 ;;; | (subseq <from> <to> . <destructuring template lambda list>) 47 ;;; <container type> ::= list | cons | vector | array 48 49 ;;; Templates for Vectors and Arrays. 50 ;;; 51 ;;; <vector template> ::= (vector . <destructuring template lambda list>) 52 ;;; 53 ;;; <array template> ::= (array <shape template>) 54 ;;; | (<array CL type specifier> <shape template>) 55 ;;; | (array (['*' | <element type>] [<dimension spec>]]) <shape template>) 56 ;;; | (aref <index template> <template>) 57 ;;; <shape template> ::= <destructuring template lambda list> 58 ;;; | <sequence template> 59 ;;; | (<shape template>) 60 61 ;;; Templates for LIST and CONS 62 ;;; <list template> ::= (list . <destructuring template lambda list>) 63 ;;; <cons template> ::= (cons <template> <template>) 64 65 ;;; A regular list or cons acts as a list (hence as a sequence) template, or a cons template. 66 67 (define-condition unification-template-error (simple-error) 68 ()) 69 70 ;;; Templates are introduced by the reader macro #T(...) 71 72 (defclass template () 73 ((spec :accessor template-spec :type (or symbol cons) :initarg :spec)) 74 (:default-initargs :spec nil)) 75 76 (defgeneric template-p (x) 77 (:method ((x template)) t) 78 (:method ((x t)) nil)) 79 80 81 (defclass type-template (template) ()) 82 83 (defgeneric type-template-p (x) 84 (:method ((x type-template)) t) 85 (:method ((x t)) nil)) 86 87 88 (defgeneric type-template-type-spec (x) 89 (:method ((x type-template)) 90 (let ((spec (template-spec x))) 91 (if spec 92 (first spec) 93 'null)))) 94 95 96 97 (defclass nil-template (type-template) ()) ; This is the point where we break the type hierarchy. 98 99 (defgeneric nil-template-p (x) 100 (:method ((x nil-template)) t) 101 (:method ((x t)) nil)) 102 103 104 (defclass expression-template (template) ()) 105 106 (defgeneric expression-template-p (x) 107 (:method ((x expression-template)) t) 108 (:method ((x t)) nil)) 109 110 111 (defmethod print-object ((template template) stream) 112 (format stream "#T~S" (template-spec template))) 113 114 115 (defclass sequence-template (type-template) ()) 116 117 (defgeneric sequence-template-p (x) 118 (:method ((x sequence-template)) t) 119 (:method ((x t)) nil)) 120 121 122 (defclass list-template (sequence-template) ()) 123 124 (defgeneric list-template-p (x) 125 (:method ((x list-template)) t) 126 (:method ((x t)) nil)) 127 128 129 (defclass lambda-template (list-template expression-template) ()) 130 131 (defgeneric lambda-template-p (x) 132 (:method ((x lambda-template)) t) 133 (:method ((x t)) nil)) 134 135 136 137 (defclass array-template (type-template) ()) 138 139 (defgeneric array-template-p (x) 140 (:method ((x array-template)) t) 141 (:method ((x t)) nil)) 142 143 144 (defclass vector-template (sequence-template array-template) ()) 145 146 (defgeneric vector-template-p (x) 147 (:method ((x vector-template)) t) 148 (:method ((x t)) nil)) 149 150 151 (defclass string-template (vector-template) ()) 152 153 (defgeneric string-template-p (x) 154 (:method ((x string-template)) t) 155 (:method ((x t)) nil)) 156 157 158 159 160 (defclass symbol-template (type-template) ()) 161 162 (defgeneric symbol-template-p (x) 163 (:method ((x symbol-template)) t) 164 (:method ((x t)) nil)) 165 166 167 (defclass number-template (type-template) ()) 168 169 (defgeneric number-template-p (x) 170 (:method ((x number-template)) t) 171 (:method ((x t)) nil)) 172 173 174 (defclass structure-object-template (type-template) ()) 175 176 (defgeneric structure-object-template-p (x) 177 (:method ((x structure-object-template)) t) 178 (:method ((x t)) nil)) 179 180 181 (defclass standard-object-template (type-template) ()) 182 183 (defgeneric standard-object-template-p (x) 184 (:method ((x standard-object-template)) t) 185 (:method ((x t)) nil)) 186 187 188 ;;; Expression Templates. 189 190 (defclass subseq-template (expression-template) ()) 191 192 (defgeneric subseq-template-p (x) 193 (:method ((x subseq-template)) t) 194 (:method ((x t)) nil)) 195 196 197 198 (defclass element-template (expression-template) ()) 199 200 (defgeneric element-template-p (x) 201 (:method ((x element-template)) t) 202 (:method ((x t)) nil)) 203 204 205 (defclass elt-template (element-template) ()) 206 207 (defgeneric elt-template-p (x) 208 (:method ((x elt-template)) t) 209 (:method ((x t)) nil)) 210 211 212 (defclass aref-template (element-template) ()) 213 214 (defgeneric aref-template-p (x) 215 (:method ((x aref-template)) t) 216 (:method ((x t)) nil)) 217 218 219 (defclass nth-template (element-template) ()) 220 221 (defgeneric nth-template-p (x) 222 (:method ((x nth-template)) t) 223 (:method ((x t)) nil)) 224 225 226 (defclass nthcdr-template (element-template) ()) 227 228 (defgeneric nthcdr-template-p (x) 229 (:method ((x nthcdr-template)) t) 230 (:method ((x t)) nil)) 231 232 233 (defgeneric make-template (kind spec)) 234 235 236 (defmethod make-template ((kind null) (spec symbol)) 237 (assert (null spec) (spec) "MAKE-TEMPLATE called erroneously with ~S and ~S." kind spec) 238 (make-instance 'nil-template :spec spec)) 239 240 (defmethod make-template ((kind symbol) (spec symbol)) 241 (make-instance 'symbol-template :spec spec)) 242 243 (defmethod make-template ((kind (eql 'symbol)) (spec cons)) 244 (make-instance 'symbol-template :spec spec)) 245 246 (defmethod make-template ((kind symbol) (spec cons)) 247 (cond ((subtypep kind 'number) 248 (make-instance 'number-template :spec spec)) 249 ((subtypep kind 'structure-object) 250 (make-instance 'structure-object-template :spec spec)) 251 ((subtypep kind 'standard-object) 252 (make-instance 'standard-object-template :spec spec)) 253 (t 254 (error 'unification-template-error 255 :format-control "Unknown template specifier ~S." 256 :format-arguments (list kind))) 257 )) 258 259 (defmethod make-template ((kind cons) (spec cons)) 260 (cond ((subtypep kind 'number) 261 (make-instance 'number-template :spec spec)) 262 ((subtypep kind 'string) 263 (make-instance 'string-template :spec spec)) 264 ((subtypep kind 'vector) 265 (make-instance 'vector-template :spec spec)) 266 ((subtypep kind 'array) 267 (make-instance 'array-template :spec spec)) 268 (t 269 (error 'unification-template-error 270 :format-control "Unknown template specifier ~S." 271 :format-arguments (list kind))) 272 )) 273 274 (defmethod make-template ((kind number) (spec number)) 275 (assert (= kind spec)) 276 (make-instance 'number-template :spec spec)) 277 278 (defmethod make-template ((kind (eql 'sequence)) (spec cons)) 279 (make-instance 'sequence-template :spec spec)) 280 281 (defmethod make-template ((kind (eql 'list)) (spec cons)) 282 (make-instance 'list-template :spec spec)) 283 284 (defmethod make-template ((kind (eql 'lambda)) (spec cons)) 285 (make-instance 'lambda-template :spec spec)) 286 287 (defmethod make-template ((kind (eql 'vector)) (spec cons)) 288 (make-instance 'vector-template :spec spec)) 289 290 (defmethod make-template ((kind (eql 'string)) (spec cons)) 291 (make-instance 'string-template :spec spec)) 292 293 (defmethod make-template ((kind (eql 'array)) (spec cons)) 294 (make-instance 'array-template :spec spec)) 295 296 297 (defmethod make-template ((kind (eql 'subseq)) (spec cons)) 298 (make-instance 'subseq-template :spec spec)) 299 300 (defmethod make-template ((kind (eql 'elt)) (spec cons)) 301 (make-instance 'elt-template :spec spec)) 302 303 (defmethod make-template ((kind (eql 'aref)) (spec cons)) 304 (make-instance 'aref-template :spec spec)) 305 306 (defmethod make-template ((kind (eql 'nth)) (spec cons)) 307 (make-instance 'nth-template :spec spec)) 308 309 (defmethod make-template ((kind (eql 'nthcdr)) (spec cons)) 310 (make-instance 'nthcdr-template :spec spec)) 311 312 313 314 ;;;;=========================================================================== 315 ;;;; Implementation. 316 317 ;;; Symbol Templates. 318 ;;; Specification is 319 ;;; 320 ;;; (symbol <symbol>) 321 322 (defun symbol-template-symbol (x) 323 (declare (type symbol-template x)) 324 (assert (symbol-template-p x) (x) "Non symbol template ~S." x) 325 (let ((spec (template-spec x))) 326 (cond ((symbolp spec) spec) 327 ((consp spec) (second spec))))) 328 329 330 ;;; Number template 331 ;;; Specification is 332 ;;; 333 ;;; (<number type> <number>) 334 ;;; or 335 ;;; 336 ;;; <number> 337 338 (defun number-template-number (x) 339 (declare (type number-template x)) 340 (assert (number-template-p x) (x) "Non number template ~S." x) 341 (let ((spec (template-spec x))) 342 (etypecase spec 343 (symbol spec) 344 (number spec) 345 (cons (second spec))))) 346 347 348 (defun number-template-numeric-type (x) 349 (declare (type number-template x)) 350 (let ((n (number-template-number x))) 351 (if (numberp n) 352 (type-of n) 353 (first (template-spec x))))) 354 355 (defun number-template-numeric-class (x) 356 (declare (type number-template x)) 357 (let ((n (number-template-number x))) 358 (if (numberp n) 359 (class-of n) 360 (find-class (first (template-spec x)))))) 361 362 363 364 365 ;;; Sequence Templates. 366 ;;; Specification is 367 ;;; 368 ;;; (<sequence subtype> . <destructuring template lambda list>) 369 ;;; or 370 ;;; (subseq <from> <to> . <destructuring template lambda list>) 371 372 (defun sequence-template-lambda-list (x) 373 (declare (type sequence-template x)) 374 (assert (sequence-template-p x) (x) "Non sequence template ~S." x) 375 (rest (template-spec x))) 376 377 378 ;;; Vector Templates. 379 ;;; Specification is 380 ;;; 381 ;;; (<vector type specifier> . <destructuring template lambda list>) 382 383 (defun vector-template-element-type (x) 384 (declare (type vector-template x)) 385 (assert (vector-template-p x) (x) "Non vector template ~S." x) 386 (let ((spec (type-template-type-spec x))) 387 (if (consp spec) 388 (destructuring-bind (vector-kwd &optional (element-type '*) size) 389 spec 390 (declare (ignore vector-kwd size)) 391 element-type) 392 '*))) 393 394 395 (defun vector-template-size (x) 396 (declare (type vector-template x)) 397 (assert (vector-template-p x) (x) "Non vector template ~S." x) 398 (let ((spec (type-template-type-spec x))) 399 (if (consp spec) 400 (destructuring-bind (vector-kwd &optional element-type (size '*)) 401 spec 402 (declare (ignore vector-kwd element-type)) 403 size) 404 '*))) 405 406 407 ;;; Array Templates. 408 ;;; Specification is 409 ;;; 410 ;;; (array (['*' | <element type>] [<dimension spec>]) <shape template>) 411 ;;; or 412 ;;; (<array type specifier> <shape template>) 413 414 415 (defun array-template-shape-template (x) 416 (declare (type array-template x)) 417 (assert (array-template-p x) (x) "Non array template ~S." x) 418 (let ((t-spec (template-spec x))) 419 (if (= 2 (list-length t-spec)) 420 (second t-spec) 421 (third t-spec)))) 422 423 424 (defun array-template-element-type (x) 425 (declare (type array-template x)) 426 (assert (array-template-p x) (x) "Non array template ~S." x) 427 (let ((type-spec (type-template-type-spec x))) 428 (if (consp type-spec) 429 (destructuring-bind (array-kwd &optional (element-type '*) dimension-spec) 430 type-spec 431 (declare (ignore array-kwd dimension-spec)) 432 element-type) 433 '*))) 434 435 436 (defun array-template-dimensions (x) 437 (declare (type array-template x)) 438 (assert (array-template-p x) (x) "Non array template ~S." x) 439 (let ((type-spec (type-template-type-spec x))) 440 (if (consp type-spec) 441 (destructuring-bind (array-kwd &optional element-type (dimension-spec '*)) 442 type-spec 443 (declare (ignore array-kwd element-type)) 444 dimension-spec) 445 '*))) 446 447 448 449 ;;; Structure and Standard Object Templates. 450 451 (defun structure-object-template-class (x) 452 (and (structure-object-template-p x) 453 (first (template-spec x)))) 454 455 (defun structure-object-template-slots (x) 456 (and (structure-object-template-p x) 457 (rest (template-spec x)))) 458 459 460 (defun standard-object-template-class (x) 461 (and (standard-object-template-p x) 462 (first (template-spec x)))) 463 464 (defun standard-object-template-slots (x) 465 (and (standard-object-template-p x) 466 (rest (template-spec x)))) 467 468 469 ;;;--------------------------------------------------------------------------- 470 ;;; Expression Templates. 471 472 473 ;;; AREF Templates. 474 475 (defun aref-template-indexes (x) 476 (declare (type aref-template x)) 477 (assert (aref-template-p x) (x) "Non aref template ~S." x) 478 (let ((spec (template-spec x))) 479 (second spec))) 480 481 482 (defun aref-template-element (x) 483 (declare (type aref-template x)) 484 (assert (aref-template-p x) (x) "Non array template ~S." x) 485 (let ((spec (template-spec x))) 486 (third spec))) 487 488 489 490 491 ;;;=========================================================================== 492 ;;; Template variables. 493 ;;; Let's walk down a template. 494 ;;; Note that there is an asymmetry here: I admit some containers to have 495 ;;; variables inside, but I do not search instances of a class for variables. 496 ;;; This is an asymmetry that would be way too hard to fix without more 497 ;;; introspective power (which is available in the MOP, but not standard.) 498 499 (defgeneric collect-template-vars (template)) 500 501 (defmethod collect-template-vars ((template template)) 502 (let ((spec (template-spec template))) 503 (nconc (collect-template-vars (car spec)) 504 (collect-template-vars (cdr spec))))) 505 506 (defmethod collect-template-vars ((template symbol-template)) 507 (let ((template (symbol-template-symbol template))) 508 (when (and (variablep template) (not (variable-any-p template))) 509 (list template)))) 510 511 512 (defmethod collect-template-vars ((template number-template)) 513 (let ((template (number-template-number template))) 514 (etypecase template 515 (number ()) 516 (symbol (cond ((and (variablep template) (not (variable-any-p template))) 517 (list template)) 518 ((and (boundp template) 519 (numberp (symbol-value template))) 520 ;; This handles cases like #T(number pi) 521 ;; It may be too broad, but for the time being it seems ok. 522 nil) 523 (t 524 (error "Invalid number template ~S." template))))))) 525 526 527 (defmethod collect-template-vars ((template symbol)) 528 (when (and (variablep template) (not (variable-any-p template))) 529 (list template))) 530 531 (defmethod collect-template-vars ((template null)) 532 ()) 533 534 (defmethod collect-template-vars ((template cons)) 535 (nconc (collect-template-vars (car template)) 536 (collect-template-vars (cdr template)))) 537 538 (defmethod collect-template-vars ((template string)) 539 ()) 540 541 542 (defmethod collect-template-vars ((template vector)) 543 (loop for e across template 544 nconc (collect-template-vars e))) 545 546 547 (defmethod collect-template-vars ((template array)) 548 (loop for i below (array-total-size template) 549 nconc (collect-template-vars (row-major-aref template i)))) 550 551 552 (defmethod collect-template-vars ((template t)) 553 ()) 554 555 ;;; end of file -- templates.lisp --