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