mdw@git.distorted.org.uk Git - sod/blob - src/class-layout-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Class layout protocol implementation
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible Object Design, an object system for C.
  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 slots.
  30
  31 (defmethod print-object ((slot effective-slot) stream)
  32   (maybe-print-unreadable-object (slot stream :type t)
  33     (format stream "~A~@[ = ~@_~A~]"
  34             (effective-slot-direct-slot slot)
  35             (effective-slot-initializer slot))))
  36
  37 (defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
  38   (some (lambda (super)
  39           (find slot
  40                 (sod-class-instance-initializers super)
  41                 :key #'sod-initializer-slot))
  42         (sod-class-precedence-list class)))
  43
  44 (defmethod find-slot-initargs ((class sod-class) (slot sod-slot))
  45   (mappend (lambda (super)
  46              (remove-if-not (lambda (initarg)
  47                               (and (typep initarg 'sod-slot-initarg)
  48                                    (eq (sod-initarg-slot initarg) slot)))
  49                             (sod-class-initargs super)))
  50            (sod-class-precedence-list class)))
  51
  52 (defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
  53   (make-instance 'effective-slot
  54                  :slot slot
  55                  :class class
  56                  :initializer (find-slot-initializer class slot)
  57                  :initargs (find-slot-initargs class slot)))
  58
  59 (defmethod find-class-initializer ((slot effective-slot) (class sod-class))
  60   (let ((dslot (effective-slot-direct-slot slot)))
  61     (or (some (lambda (super)
  62                 (find dslot (sod-class-class-initializers super)
  63                       :key #'sod-initializer-slot))
  64               (sod-class-precedence-list class))
  65         (effective-slot-initializer slot))))
  66
  67 ;;;--------------------------------------------------------------------------
  68 ;;; Special-purpose slot objects.
  69
  70 (export '(sod-class-slot
  71           sod-slot-initializer-function sod-slot-prepare-function))
  72 (defclass sod-class-slot (sod-slot)
  73   ((initializer-function :initarg :initializer-function
  74                          :type (or symbol function)
  75                          :reader sod-slot-initializer-function)
  76    (prepare-function :initarg :prepare-function :type (or symbol function)
  77                      :reader sod-slot-prepare-function))
  78   (:documentation
  79    "Special class for slots defined on `SodClass'.
  80
  81    These slots need class-specific initialization.  It's easier to keep all
  82    of the information (name, type, and how to initialize them) about these
  83    slots in one place, so that's what we do here."))
  84
  85 (defmethod shared-initialize :after
  86     ((slot sod-class-slot) slot-names &key pset)
  87   (declare (ignore slot-names))
  88   (default-slot (slot 'initializer-function)
  89     (get-property pset :initializer-function :func nil))
  90   (default-slot (slot 'prepare-function)
  91     (get-property pset :prepare-function :func nil)))
  92
  93 (export 'sod-class-effective-slot)
  94 (defclass sod-class-effective-slot (effective-slot)
  95   ((initializer-function :initarg :initializer-function
  96                          :type (or symbol function)
  97                          :reader effective-slot-initializer-function)
  98    (prepare-function :initarg :prepare-function :type (or symbol function)
  99                      :reader effective-slot-prepare-function))
 100   (:documentation
 101    "Special class for slots defined on `SodClass'.
 102
 103    This class ignores any explicit initializers and computes initializer
 104    values using the slot's INIT-FUNC slot and a magical protocol during
 105    metaclass instance construction."))
 106
 107 (defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
 108   (make-instance 'sod-class-effective-slot
 109                  :class class :slot slot
 110                  :initializer-function (sod-slot-initializer-function slot)
 111                  :prepare-function (sod-slot-prepare-function slot)
 112                  :initializer (find-slot-initializer class slot)))
 113
 114 ;;;--------------------------------------------------------------------------
 115 ;;; Effective methods.
 116
 117 (defmethod print-object ((method effective-method) stream)
 118   (maybe-print-unreadable-object (method stream :type t)
 119     (format stream "~A ~A"
 120             (effective-method-message method)
 121             (effective-method-class method))))
 122
 123 (defmethod print-object ((entry method-entry) stream)
 124   (maybe-print-unreadable-object (entry stream :type t)
 125     (format stream "~A:~A~@[ ~S~]"
 126             (method-entry-effective-method entry)
 127             (sod-class-nickname (method-entry-chain-head entry))
 128             (method-entry-role entry))))
 129
 130 (defmethod compute-sod-effective-method
 131     ((message sod-message) (class sod-class))
 132   (let ((direct-methods (mappend (lambda (super)
 133                                    (remove message
 134                                            (sod-class-methods super)
 135                                            :key #'sod-method-message
 136                                            :test-not #'eql))
 137                                  (sod-class-precedence-list class))))
 138     (make-instance (sod-message-effective-method-class message)
 139                    :message message
 140                    :class class
 141                    :direct-methods direct-methods)))
 142
 143 (defmethod compute-effective-methods ((class sod-class))
 144   (mapcan (lambda (super)
 145             (mapcar (lambda (message)
 146                       (compute-sod-effective-method message class))
 147                     (sod-class-messages super)))
 148           (sod-class-precedence-list class)))
 149
 150 ;;;--------------------------------------------------------------------------
 151 ;;; Instance layout.
 152
 153 ;;; islots
 154
 155 (defmethod print-object ((islots islots) stream)
 156   (print-unreadable-object (islots stream :type t)
 157     (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
 158             (islots-subclass islots)
 159             (islots-class islots)
 160             (islots-slots islots))))
 161
 162 (defmethod compute-islots ((class sod-class) (subclass sod-class))
 163   (make-instance 'islots
 164                  :class class
 165                  :subclass subclass
 166                  :slots (mapcar (lambda (slot)
 167                                   (compute-effective-slot subclass slot))
 168                                 (sod-class-slots class))))
 169
 170 ;;; vtable-pointer
 171 ;;; Do we need a construction protocol here?
 172
 173 (defmethod print-object ((vtp vtable-pointer) stream)
 174   (print-unreadable-object (vtp stream :type t)
 175     (format stream "~A:~A"
 176             (vtable-pointer-class vtp)
 177             (sod-class-nickname (vtable-pointer-chain-head vtp)))))
 178
 179 ;;; ichain
 180
 181 (defmethod print-object ((ichain ichain) stream)
 182   (print-unreadable-object (ichain stream :type t)
 183     (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
 184             (ichain-class ichain)
 185             (sod-class-nickname (ichain-head ichain))
 186             (ichain-body ichain))))
 187
 188 (defmethod compute-ichain ((class sod-class) chain)
 189   (let* ((chain-head (car chain))
 190          (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
 191                            :key #'sod-class-chain-head))
 192          (vtable-pointer (make-instance 'vtable-pointer
 193                                         :class class
 194                                         :chain-head chain-head
 195                                         :chain-tail chain-tail))
 196          (islots (remove-if-not #'islots-slots
 197                                 (mapcar (lambda (super)
 198                                           (compute-islots super class))
 199                                         chain))))
 200     (make-instance 'ichain
 201                    :class class
 202                    :chain-head chain-head
 203                    :chain-tail chain-tail
 204                    :body (cons vtable-pointer islots))))
 205
 206 ;;; ilayout
 207
 208 (defmethod print-object ((ilayout ilayout) stream)
 209   (print-unreadable-object (ilayout stream :type t)
 210     (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
 211             (ilayout-class ilayout)
 212             (ilayout-ichains ilayout))))
 213
 214 (defmethod compute-ilayout ((class sod-class))
 215   (make-instance 'ilayout
 216                  :class class
 217                  :ichains (mapcar (lambda (chain)
 218                                     (compute-ichain class
 219                                                     (reverse chain)))
 220                                   (sod-class-chains class))))
 221
 222 ;;;--------------------------------------------------------------------------
 223 ;;; Vtable layout.
 224
 225 ;;; vtmsgs
 226
 227 (defmethod print-object ((vtmsgs vtmsgs) stream)
 228   (print-unreadable-object (vtmsgs stream :type t)
 229     (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
 230             (vtmsgs-subclass vtmsgs)
 231             (vtmsgs-class vtmsgs)
 232             (vtmsgs-entries vtmsgs))))
 233
 234 (defmethod compute-vtmsgs
 235     ((class sod-class)
 236      (subclass sod-class)
 237      (chain-head sod-class)
 238      (chain-tail sod-class))
 239   (flet ((make-entries (message)
 240            (let ((method (find message
 241                                (sod-class-effective-methods subclass)
 242                                :key #'effective-method-message)))
 243              (make-method-entries method chain-head chain-tail))))
 244     (make-instance 'vtmsgs
 245                    :class class
 246                    :subclass subclass
 247                    :chain-head chain-head
 248                    :chain-tail chain-tail
 249                    :entries (mapcan #'make-entries
 250                                     (sod-class-messages class)))))
 251
 252 ;;; class-pointer
 253
 254 (defmethod print-object ((cptr class-pointer) stream)
 255   (print-unreadable-object (cptr stream :type t)
 256     (format stream "~A:~A"
 257             (class-pointer-metaclass cptr)
 258             (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
 259
 260 (defmethod make-class-pointer
 261     ((class sod-class) (chain-head sod-class)
 262      (metaclass sod-class) (meta-chain-head sod-class))
 263
 264   ;; Slightly tricky.  We don't necessarily want a pointer to the metaclass,
 265   ;; but to its most specific subclass on the given chain.  Fortunately, CL
 266   ;; is good at this game.
 267   (let* ((meta-chains (sod-class-chains metaclass))
 268          (meta-chain-tails (mapcar #'car meta-chains))
 269          (meta-chain-tail (find meta-chain-head meta-chain-tails
 270                                 :key #'sod-class-chain-head)))
 271     (make-instance 'class-pointer
 272                    :class class
 273                    :chain-head chain-head
 274                    :metaclass meta-chain-tail
 275                    :meta-chain-head meta-chain-head)))
 276
 277 ;;; base-offset
 278
 279 (defmethod print-object ((boff base-offset) stream)
 280   (print-unreadable-object (boff stream :type t)
 281     (format stream "~A:~A"
 282             (base-offset-class boff)
 283             (sod-class-nickname (base-offset-chain-head boff)))))
 284
 285 (defmethod make-base-offset ((class sod-class) (chain-head sod-class))
 286   (make-instance 'base-offset
 287                  :class class
 288                  :chain-head chain-head))
 289
 290 ;;; chain-offset
 291
 292 (defmethod print-object ((choff chain-offset) stream)
 293   (print-unreadable-object (choff stream :type t)
 294     (format stream "~A:~A->~A"
 295             (chain-offset-class choff)
 296             (sod-class-nickname (chain-offset-chain-head choff))
 297             (sod-class-nickname (chain-offset-target-head choff)))))
 298
 299 (defmethod make-chain-offset
 300     ((class sod-class) (chain-head sod-class) (target-head sod-class))
 301   (make-instance 'chain-offset
 302                  :class class
 303                  :chain-head chain-head
 304                  :target-head target-head))
 305
 306 ;;; vtable
 307
 308 (defmethod print-object ((vtable vtable) stream)
 309   (print-unreadable-object (vtable stream :type t)
 310     (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
 311             (vtable-class vtable)
 312             (sod-class-nickname (vtable-chain-head vtable))
 313             (vtable-body vtable))))
 314
 315 ;; Special variables used by `compute-vtable'.
 316 (defvar *done-metaclass-chains*)
 317 (defvar *done-instance-chains*)
 318
 319 (defmethod compute-vtable-items
 320     ((class sod-class) (super sod-class) (chain-head sod-class)
 321      (chain-tail sod-class) (emit function))
 322
 323   ;; If this class introduces new metaclass chains, then emit pointers to
 324   ;; them.
 325   (let* ((metasuper (sod-class-metaclass super))
 326          (metasuper-chains (sod-class-chains metasuper))
 327          (metasuper-chain-heads (mapcar (lambda (chain)
 328                                           (sod-class-chain-head (car chain)))
 329                                         metasuper-chains)))
 330     (dolist (metasuper-chain-head metasuper-chain-heads)
 331       (unless (member metasuper-chain-head *done-metaclass-chains*)
 332         (funcall emit (make-class-pointer class
 333                                           chain-head
 334                                           metasuper
 335                                           metasuper-chain-head))
 336         (push metasuper-chain-head *done-metaclass-chains*))))
 337
 338   ;; If there are new instance chains, then emit offsets to them.
 339   (let* ((chains (sod-class-chains super))
 340          (chain-heads (mapcar (lambda (chain)
 341                                 (sod-class-chain-head (car chain)))
 342                               chains)))
 343     (dolist (head chain-heads)
 344       (unless (member head *done-instance-chains*)
 345         (funcall emit (make-chain-offset class chain-head head))
 346         (push head *done-instance-chains*))))
 347
 348   ;; Finally, if there are interesting methods, emit those too.
 349   (when (sod-class-messages super)
 350     (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
 351
 352 (defmethod compute-vtable ((class sod-class) (chain list))
 353   (let* ((chain-head (car chain))
 354          (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
 355                            :key #'sod-class-chain-head))
 356          (*done-metaclass-chains* nil)
 357          (*done-instance-chains* (list chain-head))
 358          (done-superclasses nil)
 359          (items nil))
 360     (flet ((emit (item)
 361              (push item items)))
 362
 363       ;; Find the root chain in the metaclass and write a pointer.
 364       (let* ((metaclass (sod-class-metaclass class))
 365              (metaclass-root (find-root-metaclass class))
 366              (metaclass-root-head (sod-class-chain-head metaclass-root)))
 367         (emit (make-class-pointer class chain-head metaclass
 368                                   metaclass-root-head))
 369         (push metaclass-root-head *done-metaclass-chains*))
 370
 371       ;; Write an offset to the instance base.
 372       (emit (make-base-offset class chain-head))
 373
 374       ;; Now walk the chain.  As we ascend the chain, scan the class
 375       ;; precedence list of each class in reverse to ensure that we have
 376       ;; everything interesting.
 377       (dolist (super chain)
 378         (dolist (sub (reverse (sod-class-precedence-list super)))
 379           (unless (member sub done-superclasses)
 380             (compute-vtable-items class
 381                                   sub
 382                                   chain-head
 383                                   chain-tail
 384                                   #'emit)
 385             (push sub done-superclasses))))
 386
 387       ;; We're through.
 388       (make-instance 'vtable
 389                      :class class
 390                      :chain-head chain-head
 391                      :chain-tail chain-tail
 392                      :body (nreverse items)))))
 393
 394 (defmethod compute-vtables ((class sod-class))
 395   (mapcar (lambda (chain)
 396             (compute-vtable class (reverse chain)))
 397           (sod-class-chains class)))
 398
 399 ;;;--------------------------------------------------------------------------
 400 ;;; Layout interface.
 401
 402 ;; Just arrange to populate the necessary slots on demand.
 403 (flet ((check-class-is-finalized (class)
 404          (unless (eq (sod-class-state class) :finalized)
 405            (error "Class ~S is not finalized" class))))
 406     (macrolet ((define-layout-slot (slot (class) &body body)
 407                `(define-on-demand-slot sod-class ,slot (,class)
 408                   (check-class-is-finalized ,class)
 409                   ,@body)))
 410     (define-layout-slot %ilayout (class)
 411       (compute-ilayout class))
 412     (define-layout-slot effective-methods (class)
 413       (compute-effective-methods class))
 414     (define-layout-slot vtables (class)
 415       (compute-vtables class))))
 416
 417 ;;;----- That's all, folks --------------------------------------------------