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