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