| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Layout for instances and vtables |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Simple Object Definition system. |
| 11 | ;;; |
| 12 | ;;; SOD is free software; you can redistribute it and/or modify |
| 13 | ;;; it under the terms of the GNU General Public License as published by |
| 14 | ;;; the Free Software Foundation; either version 2 of the License, or |
| 15 | ;;; (at your option) any later version. |
| 16 | ;;; |
| 17 | ;;; SOD is distributed in the hope that it will be useful, |
| 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;;; GNU General Public License for more details. |
| 21 | ;;; |
| 22 | ;;; You should have received a copy of the GNU General Public License |
| 23 | ;;; along with SOD; if not, write to the Free Software Foundation, |
| 24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 25 | |
| 26 | (cl:in-package #:sod) |
| 27 | |
| 28 | ;;;-------------------------------------------------------------------------- |
| 29 | ;;; Effective slot objects. |
| 30 | |
| 31 | (defclass effective-slot () |
| 32 | ((class :initarg :class :type sod-slot :reader effective-slot-class) |
| 33 | (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot) |
| 34 | (initializer :initarg :initializer :type (or sod-initializer null) |
| 35 | :reader effective-slot-initializer)) |
| 36 | (:documentation |
| 37 | "Describes a slot and how it's meant to be initialized. |
| 38 | |
| 39 | Effective slot objects are usually attached to layouts.")) |
| 40 | |
| 41 | (defgeneric find-slot-initializer (class slot) |
| 42 | (:documentation |
| 43 | "Return the most specific initializer for SLOT, starting from CLASS.")) |
| 44 | |
| 45 | (defgeneric compute-effective-slot (class slot) |
| 46 | (:documentation |
| 47 | "Construct an effective slot from the supplied direct slot. |
| 48 | |
| 49 | SLOT is a direct slot defined on CLASS or one of its superclasses. |
| 50 | (Metaclass initializers are handled using a different mechanism.)")) |
| 51 | |
| 52 | (defmethod print-object ((slot effective-slot) stream) |
| 53 | (maybe-print-unreadable-object (slot stream :type t) |
| 54 | (format stream "~A~@[ = ~@_~A~]" |
| 55 | (effective-slot-direct-slot slot) |
| 56 | (effective-slot-initializer slot)))) |
| 57 | |
| 58 | (defmethod find-slot-initializer ((class sod-class) (slot sod-slot)) |
| 59 | (some (lambda (super) |
| 60 | (find slot |
| 61 | (sod-class-instance-initializers super) |
| 62 | :key #'sod-initializer-slot)) |
| 63 | (sod-class-precedence-list class))) |
| 64 | |
| 65 | (defmethod compute-effective-slot ((class sod-class) (slot sod-slot)) |
| 66 | (make-instance 'effective-slot |
| 67 | :slot slot |
| 68 | :class class |
| 69 | :initializer (find-slot-initializer class slot))) |
| 70 | |
| 71 | ;;;-------------------------------------------------------------------------- |
| 72 | ;;; Instance layout objects. |
| 73 | |
| 74 | ;;; islots |
| 75 | |
| 76 | (defclass islots () |
| 77 | ((class :initarg :class :type sod-class :reader islots-class) |
| 78 | (subclass :initarg :subclass :type sod-class :reader islots-subclass) |
| 79 | (slots :initarg :slots :type list :reader islots-slots)) |
| 80 | (:documentation |
| 81 | "The collection of effective SLOTS defined by an instance of CLASS.")) |
| 82 | |
| 83 | (defmethod print-object ((islots islots) stream) |
| 84 | (print-unreadable-object (islots stream :type t) |
| 85 | (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>" |
| 86 | (islots-subclass islots) |
| 87 | (islots-class islots) |
| 88 | (islots-slots islots)))) |
| 89 | |
| 90 | (defgeneric compute-islots (class subclass) |
| 91 | (:documentation |
| 92 | "Return ISLOTS containing EFFECTIVE-SLOTs for a particular CLASS. |
| 93 | |
| 94 | Initializers for the slots should be taken from the most specific |
| 95 | superclass of SUBCLASS.")) |
| 96 | |
| 97 | ;;; vtable-pointer |
| 98 | |
| 99 | (defclass vtable-pointer () |
| 100 | ((class :initarg :class :type sod-class :reader vtable-pointer-class) |
| 101 | (chain-head :initarg :chain-head :type sod-class |
| 102 | :reader vtable-pointer-chain-head) |
| 103 | (chain-tail :initarg :chain-tail :type sod-class |
| 104 | :reader vtable-pointer-chain-tail)) |
| 105 | (:documentation |
| 106 | "A pointer to the vtable for CLASS corresponding to a particular CHAIN.")) |
| 107 | |
| 108 | (defmethod print-object ((vtp vtable-pointer) stream) |
| 109 | (print-unreadable-object (vtp stream :type t) |
| 110 | (format stream "~A:~A" |
| 111 | (vtable-pointer-class vtp) |
| 112 | (sod-class-nickname (vtable-pointer-chain-head vtp))))) |
| 113 | |
| 114 | ;;; ichain |
| 115 | |
| 116 | (defclass ichain () |
| 117 | ((class :initarg :class :type sod-class :reader ichain-class) |
| 118 | (chain-head :initarg :chain-head :type sod-class :reader ichain-head) |
| 119 | (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail) |
| 120 | (body :initarg :body :type list :reader ichain-body)) |
| 121 | (:documentation |
| 122 | "All of the instance layout for CLASS corresponding to a particular CHAIN. |
| 123 | |
| 124 | The BODY is a list of things to include in the finished structure. By |
| 125 | default, it contains a VTABLE-POINTER and ISLOTS for each class in the |
| 126 | chain.")) |
| 127 | |
| 128 | (defmethod print-object ((ichain ichain) stream) |
| 129 | (print-unreadable-object (ichain stream :type t) |
| 130 | (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>" |
| 131 | (ichain-class ichain) |
| 132 | (sod-class-nickname (ichain-head ichain)) |
| 133 | (ichain-body ichain)))) |
| 134 | |
| 135 | (defgeneric compute-ichain (class chain) |
| 136 | (:documentation |
| 137 | "Return an ICHAIN for a particular CHAIN of CLASS's superclasses. |
| 138 | |
| 139 | The CHAIN is a list of classes, with the least specific first -- so the |
| 140 | chain head is the first element.")) |
| 141 | |
| 142 | ;;; ilayout |
| 143 | |
| 144 | (defclass ilayout () |
| 145 | ((class :initarg :class :type sod-class :reader ilayout-class) |
| 146 | (ichains :initarg :ichains :type list :reader ilayout-ichains)) |
| 147 | (:documentation |
| 148 | "All of the instance layout for a CLASS. |
| 149 | |
| 150 | Consists of an ICHAIN for each distinct chain.")) |
| 151 | |
| 152 | (defmethod print-object ((ilayout ilayout) stream) |
| 153 | (print-unreadable-object (ilayout stream :type t) |
| 154 | (format stream "~A ~_~:<~@{~S~^ ~_~}~:>" |
| 155 | (ilayout-class ilayout) |
| 156 | (ilayout-ichains ilayout)))) |
| 157 | |
| 158 | (defgeneric compute-ilayout (class) |
| 159 | (:documentation |
| 160 | "Compute and return an instance layout for CLASS.")) |
| 161 | |
| 162 | ;;; Standard implementation. |
| 163 | |
| 164 | (defmethod compute-islots ((class sod-class) (subclass sod-class)) |
| 165 | (make-instance 'islots |
| 166 | :class class |
| 167 | :subclass subclass |
| 168 | :slots (mapcar (lambda (slot) |
| 169 | (compute-effective-slot subclass slot)) |
| 170 | (sod-class-slots class)))) |
| 171 | |
| 172 | (defmethod compute-ichain ((class sod-class) chain) |
| 173 | (let* ((chain-head (car chain)) |
| 174 | (chain-tail (find chain-head (mapcar #'car (sod-class-chains class)) |
| 175 | :key #'sod-class-chain-head)) |
| 176 | (vtable-pointer (make-instance 'vtable-pointer |
| 177 | :class class |
| 178 | :chain-head chain-head |
| 179 | :chain-tail chain-tail)) |
| 180 | (islots (remove-if-not #'islots-slots |
| 181 | (mapcar (lambda (super) |
| 182 | (compute-islots super class)) |
| 183 | chain)))) |
| 184 | (make-instance 'ichain |
| 185 | :class class |
| 186 | :chain-head chain-head |
| 187 | :chain-tail chain-tail |
| 188 | :body (cons vtable-pointer islots)))) |
| 189 | |
| 190 | (defmethod compute-ilayout ((class sod-class)) |
| 191 | (make-instance 'ilayout |
| 192 | :class class |
| 193 | :ichains (mapcar (lambda (chain) |
| 194 | (compute-ichain class |
| 195 | (reverse chain))) |
| 196 | (sod-class-chains class)))) |
| 197 | |
| 198 | ;;;-------------------------------------------------------------------------- |
| 199 | ;;; Effective methods. |
| 200 | |
| 201 | (defclass effective-method () |
| 202 | ((message :initarg :message :type sod-message |
| 203 | :reader effective-method-message) |
| 204 | (class :initarg :class :type sod-class :reader effective-method-class)) |
| 205 | (:documentation |
| 206 | "The effective method invoked by sending MESSAGE to an instance of CLASS. |
| 207 | |
| 208 | This is not a useful class by itself. Message classes are expected to |
| 209 | define their own effective-method classes. |
| 210 | |
| 211 | An effective method class must accept a :DIRECT-METHODS initarg, which |
| 212 | will be a list of applicable methods sorted in most-to-least specific |
| 213 | order.")) |
| 214 | |
| 215 | (defmethod print-object ((method effective-method) stream) |
| 216 | (maybe-print-unreadable-object (method stream :type t) |
| 217 | (format stream "~A ~A" |
| 218 | (effective-method-message method) |
| 219 | (effective-method-class method)))) |
| 220 | |
| 221 | (defgeneric message-effective-method-class (message) |
| 222 | (:documentation |
| 223 | "Return the effective method class for the given MESSAGE.")) |
| 224 | |
| 225 | (defgeneric compute-sod-effective-method (message class) |
| 226 | (:documentation |
| 227 | "Return the effective method when a CLASS instance receives MESSAGE. |
| 228 | |
| 229 | The default method constructs an instance of the message's chosen |
| 230 | MESSAGE-EFFECTIVE-METHOD-CLASS, passing the MESSAGE, the CLASS and the |
| 231 | list of applicable methods as initargs to MAKE-INSTANCE.")) |
| 232 | |
| 233 | (defmethod compute-sod-effective-method |
| 234 | ((message sod-message) (class sod-class)) |
| 235 | (let ((direct-methods (mapcan (lambda (super) |
| 236 | (let ((method |
| 237 | (find message |
| 238 | (sod-class-methods super) |
| 239 | :key #'sod-method-message))) |
| 240 | (and method (list method)))) |
| 241 | (sod-class-precedence-list class)))) |
| 242 | (make-instance (message-effective-method-class message) |
| 243 | :message message |
| 244 | :class class |
| 245 | :direct-methods direct-methods))) |
| 246 | |
| 247 | ;;;-------------------------------------------------------------------------- |
| 248 | ;;; Vtable layout. |
| 249 | |
| 250 | ;;; method-entry |
| 251 | |
| 252 | (defclass method-entry () |
| 253 | ((method :initarg :method :type effective-method |
| 254 | :reader method-entry-effective-method) |
| 255 | (chain-head :initarg :chain-head :type sod-class |
| 256 | :reader method-entry-chain-head) |
| 257 | (chain-tail :initarg :chain-tail :type sod-class |
| 258 | :reader method-entry-chain-tail)) |
| 259 | (:documentation |
| 260 | "An entry point into an effective method. |
| 261 | |
| 262 | Calls to an effective method via different vtable chains will have their |
| 263 | `me' pointers pointing to different ichains within the instance layout. |
| 264 | Rather than (necessarily) duplicating the entire effective method for each |
| 265 | chain, we insert an entry veneer (the method entry) to fix up the pointer. |
| 266 | Exactly how it does this is up to the effective method -- and duplication |
| 267 | under some circumstances is probably a reasonable approach -- e.g., if the |
| 268 | effective method is just going to call a direct method immediately.")) |
| 269 | |
| 270 | (defmethod print-object ((entry method-entry) stream) |
| 271 | (maybe-print-unreadable-object (entry stream :type t) |
| 272 | (format stream "~A:~A" |
| 273 | (method-entry-effective-method entry) |
| 274 | (sod-class-nickname (method-entry-chain-head entry))))) |
| 275 | |
| 276 | (defgeneric make-method-entry (effective-method chain-head chain-tail) |
| 277 | (:documentation |
| 278 | "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD. |
| 279 | |
| 280 | There is no default method for this function. (Maybe when the |
| 281 | effective-method/method-entry output protocol has settled down I'll know |
| 282 | what a sensible default action would be.)")) |
| 283 | |
| 284 | ;;; vtmsgs |
| 285 | |
| 286 | (defclass vtmsgs () |
| 287 | ((class :initarg :class :type sod-class :reader vtmsgs-class) |
| 288 | (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass) |
| 289 | (chain-head :initarg :chain-head :type sod-class |
| 290 | :reader vtmsgs-chain-head) |
| 291 | (chain-tail :initarg :chain-tail :type sod-class |
| 292 | :reader vtmsgs-chain-tail) |
| 293 | (entries :initarg :entries :type list :reader vtmsgs-entries)) |
| 294 | (:documentation |
| 295 | "The message dispatch table for a particular CLASS. |
| 296 | |
| 297 | The BODY contains a list of effective method entry objects for the |
| 298 | messages defined on CLASS, customized for calling from the chain headed by |
| 299 | CHAIN-HEAD.")) |
| 300 | |
| 301 | (defmethod print-object ((vtmsgs vtmsgs) stream) |
| 302 | (print-unreadable-object (vtmsgs stream :type t) |
| 303 | (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>" |
| 304 | (vtmsgs-subclass vtmsgs) |
| 305 | (vtmsgs-class vtmsgs) |
| 306 | (vtmsgs-entries vtmsgs)))) |
| 307 | |
| 308 | (defgeneric compute-vtmsgs (class subclass chain-head chain-tail) |
| 309 | (:documentation |
| 310 | "Return a VTMSGS object containing method entries for CLASS. |
| 311 | |
| 312 | The CHAIN-HEAD describes which chain the method entries should be |
| 313 | constructed for. |
| 314 | |
| 315 | The default method simply calls MAKE-METHOD-ENTRY for each of the methods |
| 316 | and wraps a VTMSGS object around them. This ought to be enough for almost |
| 317 | all purposes.")) |
| 318 | |
| 319 | ;;; class-pointer |
| 320 | |
| 321 | (defclass class-pointer () |
| 322 | ((class :initarg :class :type sod-class :reader class-pointer-class) |
| 323 | (chain-head :initarg :chain-head :type sod-class |
| 324 | :reader class-pointer-chain-head) |
| 325 | (metaclass :initarg :metaclass :type sod-class |
| 326 | :reader class-pointer-metaclass) |
| 327 | (meta-chain-head :initarg :meta-chain-head :type sod-class |
| 328 | :reader class-pointer-meta-chain-head)) |
| 329 | (:documentation |
| 330 | "Represents a pointer to a class object for the instance's class. |
| 331 | |
| 332 | A class instance can have multiple chains. It may be useful to find any |
| 333 | of those chains from an instance of the class. Therefore the vtable |
| 334 | stores a pointer to each separate chain of the class instance.")) |
| 335 | |
| 336 | (defmethod print-object ((cptr class-pointer) stream) |
| 337 | (print-unreadable-object (cptr stream :type t) |
| 338 | (format stream "~A:~A" |
| 339 | (class-pointer-metaclass cptr) |
| 340 | (sod-class-nickname (class-pointer-meta-chain-head cptr))))) |
| 341 | |
| 342 | (defgeneric make-class-pointer (class chain-head metaclass meta-chain-head) |
| 343 | (:documentation |
| 344 | "Return a class pointer to a metaclass chain.")) |
| 345 | |
| 346 | ;;; base-offset |
| 347 | |
| 348 | (defclass base-offset () |
| 349 | ((class :initarg :class :type sod-class :reader base-offset-class) |
| 350 | (chain-head :initarg :chain-head :type sod-class |
| 351 | :reader base-offset-chain-head)) |
| 352 | (:documentation |
| 353 | "The offset of this chain to the ilayout base. |
| 354 | |
| 355 | There's only one of these per vtable.")) |
| 356 | |
| 357 | (defmethod print-object ((boff base-offset) stream) |
| 358 | (print-unreadable-object (boff stream :type t) |
| 359 | (format stream "~A:~A" |
| 360 | (base-offset-class boff) |
| 361 | (sod-class-nickname (base-offset-chain-head boff))))) |
| 362 | |
| 363 | (defgeneric make-base-offset (class chain-head) |
| 364 | (:documentation |
| 365 | "Return the base offset object for CHAIN-HEAD ichain.")) |
| 366 | |
| 367 | ;;; chain-offset |
| 368 | |
| 369 | (defclass chain-offset () |
| 370 | ((class :initarg :class :type sod-class :reader chain-offset-class) |
| 371 | (chain-head :initarg :chain-head :type sod-class |
| 372 | :reader chain-offset-chain-head) |
| 373 | (target-head :initarg :target-head :type sod-class |
| 374 | :reader chain-offset-target-head)) |
| 375 | (:documentation |
| 376 | "The offset from the CHAIN-HEAD ichain to the TARGET-HEAD ichain.")) |
| 377 | |
| 378 | (defmethod print-object ((choff chain-offset) stream) |
| 379 | (print-unreadable-object (choff stream :type t) |
| 380 | (format stream "~A:~A->~A" |
| 381 | (chain-offset-class choff) |
| 382 | (sod-class-nickname (chain-offset-chain-head choff)) |
| 383 | (sod-class-nickname (chain-offset-target-head choff))))) |
| 384 | |
| 385 | (defgeneric make-chain-offset (class chain-head target-head) |
| 386 | (:documentation |
| 387 | "Return the offset from CHAIN-HEAD to TARGET-HEAD.")) |
| 388 | |
| 389 | ;;; vtable |
| 390 | |
| 391 | (defclass vtable () |
| 392 | ((class :initarg :class :type sod-class :reader vtable-class) |
| 393 | (chain-head :initarg :chain-head :type sod-class |
| 394 | :reader vtable-chain-head) |
| 395 | (chain-tail :initarg :chain-tail :type sod-class |
| 396 | :reader vtable-chain-tail) |
| 397 | (body :initarg :body :type list :reader vtable-body)) |
| 398 | (:documentation |
| 399 | "VTABLEs hold all of the per-chain static information for a class. |
| 400 | |
| 401 | There is one vtable for each chain of each class. The vtables for a class |
| 402 | are prefixes of the corresponding chains of its subclasses. |
| 403 | |
| 404 | Vtables contain method entry pointers, pointers to class objects, and |
| 405 | the offset information used for cross-chain slot access.")) |
| 406 | |
| 407 | (defmethod print-object ((vtable vtable) stream) |
| 408 | (print-unreadable-object (vtable stream :type t) |
| 409 | (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>" |
| 410 | (vtable-class vtable) |
| 411 | (sod-class-nickname (vtable-chain-head vtable)) |
| 412 | (vtable-body vtable)))) |
| 413 | |
| 414 | (defgeneric compute-vtable (class chain) |
| 415 | (:documentation |
| 416 | "Compute the vtable layout for a chain of CLASS. |
| 417 | |
| 418 | The CHAIN is a list of classes, with the least specific first.")) |
| 419 | |
| 420 | (defgeneric compute-vtables (class) |
| 421 | (:documentation |
| 422 | "Compute the vtable layouts for CLASS. |
| 423 | |
| 424 | Returns a list of VTABLE objects in the order of CLASS's chains.")) |
| 425 | |
| 426 | ;;; Implementation. |
| 427 | |
| 428 | (defmethod compute-vtmsgs |
| 429 | ((class sod-class) |
| 430 | (subclass sod-class) |
| 431 | (chain-head sod-class) |
| 432 | (chain-tail sod-class)) |
| 433 | (flet ((make-entry (message) |
| 434 | (let ((method (find message |
| 435 | (sod-class-effective-methods subclass) |
| 436 | :key #'effective-method-message))) |
| 437 | (make-method-entry method chain-head chain-tail)))) |
| 438 | (make-instance 'vtmsgs |
| 439 | :class class |
| 440 | :subclass subclass |
| 441 | :chain-head chain-head |
| 442 | :chain-tail chain-tail |
| 443 | :entries (mapcar #'make-entry |
| 444 | (sod-class-messages class))))) |
| 445 | |
| 446 | (defmethod make-class-pointer |
| 447 | ((class sod-class) (chain-head sod-class) |
| 448 | (metaclass sod-class) (meta-chain-head sod-class)) |
| 449 | |
| 450 | ;; Slightly tricky. We don't necessarily want a pointer to the metaclass, |
| 451 | ;; but to its most specific subclass on the given chain. Fortunately, CL |
| 452 | ;; is good at this game. |
| 453 | (let* ((meta-chains (sod-class-chains metaclass)) |
| 454 | (meta-chain-tails (mapcar #'car meta-chains)) |
| 455 | (meta-chain-tail (find meta-chain-head meta-chain-tails |
| 456 | :key #'sod-class-chain-head))) |
| 457 | (make-instance 'class-pointer |
| 458 | :class class |
| 459 | :chain-head chain-head |
| 460 | :metaclass meta-chain-tail |
| 461 | :meta-chain-head meta-chain-head))) |
| 462 | |
| 463 | (defmethod make-base-offset ((class sod-class) (chain-head sod-class)) |
| 464 | (make-instance 'base-offset |
| 465 | :class class |
| 466 | :chain-head chain-head)) |
| 467 | |
| 468 | (defmethod make-chain-offset |
| 469 | ((class sod-class) (chain-head sod-class) (target-head sod-class)) |
| 470 | (make-instance 'chain-offset |
| 471 | :class class |
| 472 | :chain-head chain-head |
| 473 | :target-head target-head)) |
| 474 | |
| 475 | ;; Special variables used by COMPUTE-VTABLE. |
| 476 | (defvar *done-metaclass-chains*) |
| 477 | (defvar *done-instance-chains*) |
| 478 | |
| 479 | (defgeneric compute-vtable-items (class super chain-head chain-tail emit) |
| 480 | (:documentation |
| 481 | "Emit vtable items for a superclass of CLASS. |
| 482 | |
| 483 | This function is called for each superclass SUPER of CLASS reached on the |
| 484 | chain headed by CHAIN-HEAD. The function should call EMIT for each |
| 485 | vtable item it wants to write. |
| 486 | |
| 487 | The right way to check to see whether items have already been emitted |
| 488 | (e.g., has an offset to some other chain been emitted?) is as follows: |
| 489 | |
| 490 | * In a method on COMPUTE-VTABLE, bind a special variable to an empty |
| 491 | list or hash table. |
| 492 | |
| 493 | * In a method on this function, check the variable or hash table. |
| 494 | |
| 495 | This function is the real business end of COMPUTE-VTABLE.")) |
| 496 | |
| 497 | (defmethod compute-vtable-items |
| 498 | ((class sod-class) (super sod-class) (chain-head sod-class) |
| 499 | (chain-tail sod-class) (emit function)) |
| 500 | |
| 501 | ;; If this class introduces new metaclass chains, then emit pointers to |
| 502 | ;; them. |
| 503 | (let* ((metasuper (sod-class-metaclass super)) |
| 504 | (metasuper-chains (sod-class-chains metasuper)) |
| 505 | (metasuper-chain-heads (mapcar (lambda (chain) |
| 506 | (sod-class-chain-head (car chain))) |
| 507 | metasuper-chains))) |
| 508 | (dolist (metasuper-chain-head metasuper-chain-heads) |
| 509 | (unless (member metasuper-chain-head *done-metaclass-chains*) |
| 510 | (funcall emit (make-class-pointer class |
| 511 | chain-head |
| 512 | metasuper |
| 513 | metasuper-chain-head)) |
| 514 | (push metasuper-chain-head *done-metaclass-chains*)))) |
| 515 | |
| 516 | ;; If there are new instance chains, then emit offsets to them. |
| 517 | (let* ((chains (sod-class-chains super)) |
| 518 | (chain-heads (mapcar (lambda (chain) |
| 519 | (sod-class-chain-head (car chain))) |
| 520 | chains))) |
| 521 | (dolist (head chain-heads) |
| 522 | (unless (member head *done-instance-chains*) |
| 523 | (funcall emit (make-chain-offset class chain-head head)) |
| 524 | (push head *done-instance-chains*)))) |
| 525 | |
| 526 | ;; Finally, if there are interesting methods, emit those too. |
| 527 | (when (sod-class-messages super) |
| 528 | (funcall emit (compute-vtmsgs super class chain-head chain-tail)))) |
| 529 | |
| 530 | (defun find-root-superclass (class) |
| 531 | "Returns the `root' superclass of CLASS. |
| 532 | |
| 533 | The root superclass is the superclass which itself has no direct |
| 534 | superclasses. In universes not based on the provided builtin module, the |
| 535 | root class may not be our beloved SodObject; however, there must be one |
| 536 | (otherwise the class graph is cyclic, which should be forbidden), and we |
| 537 | instist that it be unique." |
| 538 | |
| 539 | ;; The root superclass must be a chain head since the chains partition the |
| 540 | ;; superclasses; the root has no superclasses so it can't have a link and |
| 541 | ;; must therefore be a head. This narrows the field down quite a lot. |
| 542 | ;; |
| 543 | ;; Note! This function gets called from CHECK-SOD-CLASS before the class's |
| 544 | ;; chains have been computed. Therefore we iterate over the direct |
| 545 | ;; superclass's chains rather than the class's own. This misses a chain |
| 546 | ;; only in the case where the class is its own chain head. There are two |
| 547 | ;; subcases: if there are no direct superclasses at all, then the class is |
| 548 | ;; its own root; otherwise, it clearly can't be the root and the omission |
| 549 | ;; is harmless. |
| 550 | (let* ((supers (sod-class-direct-superclasses class)) |
| 551 | (roots (if supers |
| 552 | (remove-if #'sod-class-direct-superclasses |
| 553 | (mapcar (lambda (super) |
| 554 | (sod-class-chain-head super)) |
| 555 | supers)) |
| 556 | (list class)))) |
| 557 | (cond ((null roots) (error "Class ~A has no root class!" class)) |
| 558 | ((cdr roots) (error "Class ~A has multiple root classes ~ |
| 559 | ~{~A~#[~; and ~;, ~]~}" |
| 560 | class roots)) |
| 561 | (t (car roots))))) |
| 562 | |
| 563 | (defun find-root-metaclass (class) |
| 564 | "Returns the `root' metaclass of CLASS. |
| 565 | |
| 566 | The root metaclass is the metaclass of the root superclass -- see |
| 567 | FIND-ROOT-SUPERCLASS." |
| 568 | (sod-class-metaclass (find-root-superclass class))) |
| 569 | |
| 570 | (defmethod compute-vtable ((class sod-class) (chain list)) |
| 571 | (let* ((chain-head (car chain)) |
| 572 | (chain-tail (find chain-head (mapcar #'car (sod-class-chains class)) |
| 573 | :key #'sod-class-chain-head)) |
| 574 | (*done-metaclass-chains* nil) |
| 575 | (*done-instance-chains* (list chain-head)) |
| 576 | (done-superclasses nil) |
| 577 | (items nil)) |
| 578 | (flet ((emit (item) |
| 579 | (push item items))) |
| 580 | |
| 581 | ;; Find the root chain in the metaclass and write a pointer. |
| 582 | (let* ((metaclass (sod-class-metaclass class)) |
| 583 | (metaclass-root (find-root-metaclass class)) |
| 584 | (metaclass-root-head (sod-class-chain-head metaclass-root))) |
| 585 | (emit (make-class-pointer class chain-head metaclass |
| 586 | metaclass-root-head)) |
| 587 | (push metaclass-root-head *done-metaclass-chains*)) |
| 588 | |
| 589 | ;; Write an offset to the instance base. |
| 590 | (emit (make-base-offset class chain-head)) |
| 591 | |
| 592 | ;; Now walk the chain. As we ascend the chain, scan the class |
| 593 | ;; precedence list of each class in reverse to ensure that we have |
| 594 | ;; everything interesting. |
| 595 | (dolist (super chain) |
| 596 | (dolist (sub (reverse (sod-class-precedence-list super))) |
| 597 | (unless (member sub done-superclasses) |
| 598 | (compute-vtable-items class |
| 599 | sub |
| 600 | chain-head |
| 601 | chain-tail |
| 602 | #'emit) |
| 603 | (push sub done-superclasses)))) |
| 604 | |
| 605 | ;; We're through. |
| 606 | (make-instance 'vtable |
| 607 | :class class |
| 608 | :chain-head chain-head |
| 609 | :chain-tail chain-tail |
| 610 | :body (nreverse items))))) |
| 611 | |
| 612 | (defgeneric compute-effective-methods (class) |
| 613 | (:documentation |
| 614 | "Return a list of all of the effective methods needed for CLASS. |
| 615 | |
| 616 | The list needn't be in any particular order.")) |
| 617 | |
| 618 | (defmethod compute-effective-methods ((class sod-class)) |
| 619 | (mapcan (lambda (super) |
| 620 | (mapcar (lambda (message) |
| 621 | (compute-sod-effective-method message class)) |
| 622 | (sod-class-messages super))) |
| 623 | (sod-class-precedence-list class))) |
| 624 | |
| 625 | (defmethod compute-vtables ((class sod-class)) |
| 626 | (mapcar (lambda (chain) |
| 627 | (compute-vtable class (reverse chain))) |
| 628 | (sod-class-chains class))) |
| 629 | |
| 630 | ;;;-------------------------------------------------------------------------- |
| 631 | ;;; Names of things. |
| 632 | |
| 633 | (defun islots-struct-tag (class) |
| 634 | (format nil "~A__islots" class)) |
| 635 | |
| 636 | (defun ichain-struct-tag (class chain-head) |
| 637 | (format nil "~A__ichain_~A" class (sod-class-nickname chain-head))) |
| 638 | |
| 639 | (defun ichain-union-tag (class chain-head) |
| 640 | (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head))) |
| 641 | |
| 642 | (defun ilayout-struct-tag (class) |
| 643 | (format nil "~A__ilayout" class)) |
| 644 | |
| 645 | (defun vtmsgs-struct-tag (class super) |
| 646 | (format nil "~A__vtmsgs_~A" class (sod-class-nickname super))) |
| 647 | |
| 648 | (defun vtable-struct-tag (class chain-head) |
| 649 | (format nil "~A__vt_~A" class (sod-class-nickname chain-head))) |
| 650 | |
| 651 | (defun vtable-name (class chain-head) |
| 652 | (format nil "~A__vtable_~A" class (sod-class-nickname chain-head))) |
| 653 | |
| 654 | ;;;----- That's all, folks -------------------------------------------------- |