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