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