mdw@git.distorted.org.uk Git - sod/blob - src/class-output.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Output for classes
   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 ;;; Walking the layout tree.
  30
  31 (defmethod hook-output :after ((class sod-class) reason sequencer)
  32   "Register hooks for the class layout, direct methods, effective methods,
  33    and vtables."
  34   (with-slots ((ilayout %ilayout) vtables methods effective-methods) class
  35     (hook-output ilayout reason sequencer)
  36     (dolist (method methods) (hook-output method reason sequencer))
  37     (dolist (method effective-methods) (hook-output method reason sequencer))
  38     (dolist (vtable vtables) (hook-output vtable reason sequencer))))
  39
  40 (defmethod hook-output :after ((ilayout ilayout) reason sequencer)
  41   "Register hooks for the layout's ichains."
  42   (with-slots (ichains) ilayout
  43     (dolist (ichain ichains) (hook-output ichain reason sequencer))))
  44
  45 (defmethod hook-output :after ((ichain ichain) reason sequencer)
  46   "Register hooks for the ichain body's items."
  47   (dolist (item (ichain-body ichain)) (hook-output item reason sequencer)))
  48
  49 (defmethod hook-output :after ((islots islots) reason sequencer)
  50   "Register hooks for the islots structure's individual slots."
  51   (dolist (slot (islots-slots islots)) (hook-output slot reason sequencer)))
  52
  53 (defmethod hook-output :after ((vtable vtable) reason sequencer)
  54   "Register hooks for the vtable body's items."
  55   (with-slots (body) vtable
  56     (dolist (item body) (hook-output item reason sequencer))))
  57
  58 (defmethod hook-output :after ((vtmsgs vtmsgs) reason sequencer)
  59   "Register hooks for the vtmsgs structure's individual method entries."
  60   (with-slots (entries) vtmsgs
  61     (dolist (entry entries) (hook-output entry reason sequencer))))
  62
  63 ;;;--------------------------------------------------------------------------
  64 ;;; Class declarations.
  65
  66 (export 'emit-class-typedef)
  67 (defgeneric emit-class-typedef (class stream)
  68   (:documentation
  69    "Emit a `typedef' for the CLASS's C class type to the output STREAM.
  70
  71    By default, this will be an alias for the class's home `ichain'
  72    structure."))
  73 (defmethod emit-class-typedef ((class sod-class) stream)
  74   (format stream "typedef struct ~A ~A;~%"
  75           (ichain-struct-tag class (sod-class-chain-head class)) class))
  76
  77 (export 'emit-class-object-decl)
  78 (defgeneric emit-class-object-decl (class stream)
  79   (:documentation
  80    "Emit the declaration and macros for the CLASS's class object.
  81
  82    This includes the main declaration, and the convenience macros for
  83    referring to the class object's individual chains.  Write everything to
  84    the output STREAM."))
  85 (defmethod emit-class-object-decl ((class sod-class) stream)
  86   (let ((metaclass (sod-class-metaclass class))
  87         (metaroot (find-root-metaclass class)))
  88
  89     ;; Output the actual class object declaration, and the special
  90     ;; `...__class' macro for the root-metaclass chain.
  91     (format stream "/* The class object. */~@
  92                     extern const struct ~A ~A__classobj;~@
  93                     #define ~:*~A__class (&~:*~A__classobj.~A.~A)~%"
  94             (ilayout-struct-tag metaclass) class
  95             (sod-class-nickname (sod-class-chain-head metaroot))
  96             (sod-class-nickname metaroot))
  97
  98     ;; Write the uglier `...__cls_...' macros for the class object's other
  99     ;; chains, if any.
 100     (dolist (chain (sod-class-chains metaclass))
 101       (let ((tail (car chain)))
 102         (unless (eq tail metaroot)
 103           (format stream "#define ~A__cls_~A (&~2:*~A__classobj.~A.~A)~%"
 104                   class (sod-class-nickname (sod-class-chain-head tail))
 105                   (sod-class-nickname tail)))))
 106     (terpri stream)))
 107
 108 (export 'emit-class-conversion-macro)
 109 (defgeneric emit-class-conversion-macro (class super stream)
 110   (:documentation
 111    "Emit a macro for converting an instance of CLASS to an instance of SUPER.
 112
 113    By default this is named `CLASS__CONV_SPR'.  In-chain upcasts are just a
 114    trivial pointer cast, which any decent compiler will elide; cross-chain
 115    upcasts use the `SOD_XCHAIN' macro.  Write the macro to the output
 116    STREAM."))
 117 (defmethod emit-class-conversion-macro
 118     ((class sod-class) (super sod-class) stream)
 119   (let ((super-head (sod-class-chain-head super)))
 120     (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~
 121                     ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%"
 122             class (sod-class-nickname super) super
 123             (eq super-head (sod-class-chain-head class))
 124             (sod-class-nickname super-head))))
 125
 126 (export 'emit-message-macro-defn)
 127 (defgeneric emit-message-macro-defn
 128     (class entry varargsp me in-names out-names stream)
 129   (:documentation
 130    "Output a message macro for invoking a method ENTRY, with given arguments.
 131
 132    The default method on `emit-message-macro' calcualates the necessary
 133    argument lists and calls this function to actually write the necessary
 134    `#define' line to the stream.  The intended division of responsibilities
 135    is that `emit-message-macro' handles the peculiarities of marshalling the
 136    arguments to the method entry function, while `emit-message-macro-defn'
 137    concerns itself with navigating the vtable to find the right function in
 138    the first place.")
 139   (:method :around ((class sod-class) (entry method-entry)
 140                     varargsp me in-names out-names
 141                     stream)
 142     (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
 143     (call-next-method)
 144     (when varargsp (format stream "#endif~%"))))
 145 (defmethod emit-message-macro-defn ((class sod-class) (entry method-entry)
 146                                     varargsp me in-names out-names
 147                                     stream)
 148   (format stream "#define ~A(~{~A~^, ~}) (~A)->_vt->~A.~A(~{~A~^, ~})~%"
 149           (message-macro-name class entry)
 150           in-names
 151           me
 152           (sod-class-nickname class)
 153           (method-entry-slot-name entry)
 154           out-names))
 155
 156 (export 'emit-message-macro)
 157 (defgeneric emit-message-macro (class entry stream)
 158   (:documentation
 159    "Write a macro for invoking the method ENTRY on an instance of CLASS.
 160
 161    The default behaviour is quite complicated, particular when varargs or
 162    keyword messages are involved."))
 163 (defmethod emit-message-macro ((class sod-class) (entry method-entry) stream)
 164   (when (some (lambda (message)
 165                 (or (keyword-message-p message)
 166                     (varargs-message-p message)))
 167               (sod-class-messages class)))
 168   (let* ((type (method-entry-function-type entry))
 169          (args (c-function-arguments type))
 170          (in-names nil) (out-names nil) (varargsp nil) (me "me"))
 171     (do ((args args (cdr args)))
 172         ((endp args))
 173       (let* ((raw-name (princ-to-string (argument-name (car args))))
 174              (name (if (find raw-name
 175                              (list "_vt"
 176                                    (sod-class-nickname class)
 177                                    (method-entry-slot-name entry))
 178                              :test #'string=)
 179                        (format nil "sod__a_~A" raw-name)
 180                        raw-name)))
 181         (cond ((and (cdr args) (eq (cadr args) :ellipsis))
 182                (setf varargsp t)
 183                (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
 184                (push (format nil "/*~A*/ ..." name) in-names)
 185                (push "__VA_ARGS__" out-names)
 186                (return))
 187               (t
 188                (push name in-names)
 189                (push name out-names)))))
 190     (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
 191     (emit-message-macro-defn class entry varargsp me
 192                              (nreverse in-names)
 193                              (nreverse out-names)
 194                              stream)
 195     (when varargsp (format stream "#endif~%"))))
 196
 197 (defmethod hook-output ((class sod-class) (reason (eql :h)) sequencer)
 198   "Write the skeleton of a class declaration.
 199
 200    Most of the work is done by other functions.
 201
 202      * The class type is defined by `emit-class-typedef'.
 203
 204      * The class object is declared by `emit-class-object-decl'.
 205
 206      * The upcast conversion macros are defined by `emit-class-conversion-
 207        macro'.
 208
 209      * The message invocation macros are defined by `emit-message-macro'.
 210
 211      * The class instance structure itself is constructed by the `ilayout'
 212        object.
 213
 214      * The various vtable structures are constructed by the `vtable'
 215        objects."
 216
 217   ;; Main output sequencing.
 218   (sequence-output (stream sequencer)
 219
 220     :constraint
 221     ((:classes :start)
 222      (class :banner)
 223      (class :islots :start) (class :islots :slots) (class :islots :end)
 224      (class :vtmsgs :start) (class :vtmsgs :end)
 225      (class :vtables :start) (class :vtables :end)
 226      (class :vtable-externs) (class :vtable-externs-after)
 227      (class :methods :start) (class :methods :defs)
 228      (class :methods) (class :methods :end)
 229      (class :ichains :start) (class :ichains :end)
 230      (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
 231      (class :conversions)
 232      (class :message-macros)
 233      (class :object)
 234      (:classes :end))
 235
 236     (:typedefs (emit-class-typedef class stream))
 237     ((class :banner) (banner (format nil "Class ~A" class) stream))
 238     ((class :vtable-externs-after) (terpri stream))
 239     ((class :vtable-externs) (format stream "/* Vtable structures. */~%"))
 240     ((class :object) (emit-class-object-decl class stream)))
 241
 242   ;; Maybe generate an islots structure.
 243   (when (sod-class-slots class)
 244     (sequence-output (stream sequencer)
 245       ((class :islots :start)
 246        (format stream "/* Instance slots. */~@
 247                        struct ~A {~%"
 248                (islots-struct-tag class)))
 249       ((class :islots :end)
 250        (format stream "};~2%"))))
 251
 252   ;; Declare the direct methods.
 253   (when (sod-class-methods class)
 254     (sequence-output (stream sequencer)
 255       ((class :methods :start)
 256        (format stream "/* Direct methods. */~%"))
 257       ((class :methods :end)
 258        (terpri stream))))
 259
 260   ;; Provide upcast macros which do the right thing.
 261   (when (sod-class-direct-superclasses class)
 262     (sequence-output (stream sequencer)
 263       ((class :conversions)
 264        (format stream "/* Conversion macros. */~%")
 265        (dolist (super (cdr (sod-class-precedence-list class)))
 266          (emit-class-conversion-macro class super stream))
 267        (terpri stream))))
 268
 269   ;; Provide convenience macros for sending the newly defined messages.  (The
 270   ;; macros work on all subclasses too.)
 271   ;;
 272   ;; We need each message's method entry type for this, so we need to dig it
 273   ;; out of the vtmsgs structure.  Indeed, the vtmsgs for this class contains
 274   ;; entries for precisely the messages we want to make macros for.
 275   (when (some (lambda (message)
 276                 (or (keyword-message-p message)
 277                     (varargs-message-p message)))
 278               (sod-class-messages class))
 279     (one-off-output 'varargs-macros sequencer :early-decls
 280                     (lambda (stream)
 281                       (format stream
 282                               "~%SOD__VARARGS_MACROS_PREAMBLE~%"))))
 283   (when (sod-class-messages class)
 284     (sequence-output (stream sequencer)
 285       ((class :message-macros)
 286        (let* ((vtable (find (sod-class-chain-head class)
 287                             (sod-class-vtables class)
 288                             :key #'vtable-chain-head))
 289               (vtmsgs (find-if (lambda (item)
 290                                  (and (typep item 'vtmsgs)
 291                                       (eql (vtmsgs-class item) class)))
 292                                (vtable-body vtable))))
 293          (format stream "/* Message invocation macros. */~%")
 294          (dolist (entry (vtmsgs-entries vtmsgs))
 295            (emit-message-macro class entry stream))
 296          (terpri stream))))))
 297
 298 (defmethod hook-output :after ((class sod-class) (reason (eql :h)) sequencer)
 299   "Register hooks to output CLASS's direct slots and messages."
 300
 301   ;; Output a structure member definition for each instance slot.
 302   (dolist (slot (sod-class-slots class))
 303     (hook-output slot 'islots sequencer))
 304
 305   ;; Generate a vtmsgs structure for all superclasses.
 306   (hook-output (car (sod-class-vtables class)) 'vtmsgs sequencer))
 307
 308 ;;;--------------------------------------------------------------------------
 309 ;;; Instance structure.
 310
 311 (defmethod hook-output ((slot sod-slot) (reason (eql 'islots)) sequencer)
 312   "Declare the member for an individual slot within an `islots' structure."
 313   (sequence-output (stream sequencer)
 314     (((sod-slot-class slot) :islots :slots)
 315      (pprint-logical-block (stream nil :prefix "  " :suffix ";")
 316        (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
 317      (terpri stream))))
 318
 319 (defmethod hook-output ((ilayout ilayout) (reason (eql :h)) sequencer)
 320   "Define the structure for a class layout.
 321
 322    Here we just provide the outermost structure.  It gets filled in by
 323    the `ichains' objects and their body items."
 324   (with-slots ((class %class) ichains) ilayout
 325     (sequence-output (stream sequencer)
 326       ((class :ilayout :start)
 327        (format stream "/* Instance layout. */~@
 328                        struct ~A {~%"
 329                (ilayout-struct-tag class)))
 330       ((class :ilayout :end)
 331        (format stream "};~2%")))))
 332
 333 (defmethod hook-output :after ((ilayout ilayout) (reason (eql :h)) sequencer)
 334   "Register hooks to write chain members into the overall class layout."
 335   (dolist (ichain (ilayout-ichains ilayout))
 336     (hook-output ichain 'ilayout sequencer)))
 337
 338 (defmethod hook-output ((ichain ichain) (reason (eql :h)) sequencer)
 339   "Define the layout structure for a particular chain of a class.
 340
 341    A member of this class is dropped into the `ilayout' structure by the
 342    corresponding method for the `ilayout' reason.
 343
 344    We define both the chain structure of the class, and a union of it with
 345    all of its in-chain superclasses (so as to invoke the common-prefix
 346    rule)."
 347   (with-slots ((class %class) chain-head chain-tail) ichain
 348     (when (eq class chain-tail)
 349       (sequence-output (stream sequencer)
 350         :constraint ((class :ichains :start)
 351                      (class :ichain chain-head :start)
 352                      (class :ichain chain-head :slots)
 353                      (class :ichain chain-head :end)
 354                      (class :ichains :end))
 355         ((class :ichain chain-head :start)
 356          (format stream "/* Instance chain structure. */~@
 357                          struct ~A {~%"
 358                  (ichain-struct-tag chain-tail chain-head)))
 359         ((class :ichain chain-head :end)
 360          (format stream "};~2%")
 361          (format stream "/* Union of equivalent superclass chains. */~@
 362                          union ~A {~@
 363                          ~:{  struct ~A ~A;~%~}~
 364                          };~2%"
 365                  (ichain-union-tag chain-tail chain-head)
 366
 367                  ;; Make sure the most specific class is first: only the
 368                  ;; first element of a union can be statically initialized in
 369                  ;; C90.
 370                  (mapcar (lambda (super)
 371                            (list (ichain-struct-tag super chain-head)
 372                                  (sod-class-nickname super)))
 373                          (sod-class-chain chain-tail))))))))
 374
 375 (defmethod hook-output ((ichain ichain) (reason (eql 'ilayout)) sequencer)
 376   "Declare the member for a class chain within the class layout."
 377   (with-slots ((class %class) chain-head chain-tail) ichain
 378     (sequence-output (stream sequencer)
 379       ((class :ilayout :slots)
 380        (format stream "  union ~A ~A;~%"
 381                (ichain-union-tag chain-tail chain-head)
 382                (sod-class-nickname chain-head))))))
 383
 384 (defmethod hook-output ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
 385   "Declare the member for a vtable pointer within an `ichain' structure."
 386   (with-slots ((class %class) chain-head chain-tail) vtptr
 387     (when (eq class chain-tail)
 388       (sequence-output (stream sequencer)
 389         ((class :ichain chain-head :slots)
 390          (format stream "  const struct ~A *_vt;~%"
 391                  (vtable-struct-tag chain-tail chain-head)))))))
 392
 393 (defmethod hook-output ((islots islots) (reason (eql :h)) sequencer)
 394   "Declare the member for a class's `islots' within an `ichain' structure."
 395   (with-slots ((class %class) subclass slots) islots
 396     (let ((head (sod-class-chain-head class)))
 397       (when (eq head (sod-class-chain-head subclass))
 398         (sequence-output (stream sequencer)
 399           ((subclass :ichain (sod-class-chain-head class) :slots)
 400            (format stream "  struct ~A ~A;~%"
 401                    (islots-struct-tag class)
 402                    (sod-class-nickname class))))))))
 403
 404 ;;;--------------------------------------------------------------------------
 405 ;;; Vtable structure.
 406
 407 (defmethod hook-output ((method sod-method) (reason (eql :h)) sequencer)
 408   "Emit declarations for a direct method.
 409
 410    We declare the direct method function, and, if necessary, the `suppliedp'
 411    structure for its keyword arguments."
 412
 413   (with-slots ((class %class)) method
 414     (sequence-output (stream sequencer)
 415       ((class :methods)
 416        (let ((type (sod-method-function-type method)))
 417          (princ "extern " stream)
 418          (pprint-c-type (commentify-function-type type) stream
 419                         (sod-method-function-name method))
 420          (format stream ";~%")))
 421       ((class :methods :defs)
 422        (let* ((type (sod-method-type method))
 423               (keys (and (typep type 'c-keyword-function-type)
 424                          (c-function-keywords type))))
 425          (when keys
 426            (format stream "struct ~A {~%~
 427                            ~{  unsigned ~A: 1;~%~}~
 428                            };~2%"
 429                    (direct-method-suppliedp-struct-tag method)
 430                    (mapcar #'argument-name keys))))))))
 431
 432 (defmethod hook-output ((vtable vtable) (reason (eql :h)) sequencer)
 433   "Define the structure for a vtable.
 434
 435    We define the vtable structure of the class, and a union of it with all of
 436    its in-chain superclasses (so as to invoke the common-prefix rule).  We
 437    also declare the vtable object, defined by the corresponding `:c' method."
 438   (with-slots ((class %class) chain-head chain-tail) vtable
 439     (when (eq class chain-tail)
 440       (sequence-output (stream sequencer)
 441         :constraint ((class :vtables :start)
 442                      (class :vtable chain-head :start)
 443                      (class :vtable chain-head :slots)
 444                      (class :vtable chain-head :end)
 445                      (class :vtables :end))
 446         ((class :vtable chain-head :start)
 447          (format stream "/* Vtable structure. */~@
 448                          struct ~A {~%"
 449                  (vtable-struct-tag chain-tail chain-head)))
 450         ((class :vtable chain-head :end)
 451          (format stream "};~2%")
 452          (format stream "/* Union of equivalent superclass vtables. */~@
 453                          union ~A {~@
 454                          ~:{  struct ~A ~A;~%~}~
 455                          };~2%"
 456                  (vtable-union-tag chain-tail chain-head)
 457
 458                  ;; As for the ichain union, make sure the most specific
 459                  ;; class is first.
 460                  (mapcar (lambda (super)
 461                            (list (vtable-struct-tag super chain-head)
 462                                  (sod-class-nickname super)))
 463                          (sod-class-chain chain-tail))))))
 464     (sequence-output (stream sequencer)
 465       ((class :vtable-externs)
 466        (format stream "~@<extern const union ~A ~2I~_~A;~:>~%"
 467                (vtable-union-tag chain-tail chain-head)
 468                (vtable-name class chain-head))))))
 469
 470 (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
 471   "Declare the member for a class's `vtmsgs' within a `vtable' structure."
 472   (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs
 473     (when (eq subclass chain-tail)
 474       (sequence-output (stream sequencer)
 475         ((subclass :vtable chain-head :slots)
 476          (format stream "  struct ~A ~A;~%"
 477                  (vtmsgs-struct-tag subclass class)
 478                  (sod-class-nickname class)))))))
 479
 480 (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer)
 481   "Define the `vtmsgs' structure for a class's method entry functions."
 482   (when (vtmsgs-entries vtmsgs)
 483     (with-slots ((class %class) subclass) vtmsgs
 484       (sequence-output (stream sequencer)
 485         :constraint ((subclass :vtmsgs :start)
 486                      (subclass :vtmsgs class :start)
 487                      (subclass :vtmsgs class :slots)
 488                      (subclass :vtmsgs class :end)
 489                      (subclass :vtmsgs :end))
 490         ((subclass :vtmsgs class :start)
 491          (format stream "/* Messages protocol from class ~A */~@
 492                          struct ~A {~%"
 493                  class
 494                  (vtmsgs-struct-tag subclass class)))
 495         ((subclass :vtmsgs class :end)
 496          (format stream "};~2%"))))))
 497
 498 (defmethod hook-output ((entry method-entry)
 499                         (reason (eql 'vtmsgs)) sequencer)
 500   "Declare the member for a method entry within a `vtmsgs' structure."
 501   (let* ((method (method-entry-effective-method entry))
 502          (message (effective-method-message method))
 503          (class (effective-method-class method))
 504          (function-type (method-entry-function-type entry))
 505          (commented-type (commentify-function-type function-type))
 506          (pointer-type (make-pointer-type commented-type)))
 507     (sequence-output (stream sequencer)
 508       ((class :vtmsgs (sod-message-class message) :slots)
 509        (pprint-logical-block (stream nil :prefix "  " :suffix ";")
 510          (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
 511        (terpri stream)))))
 512
 513 (defmethod hook-output ((cptr class-pointer) (reason (eql :h)) sequencer)
 514   "Declare the member for a class-chain pointer within a `vtmsgs' structure."
 515   (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
 516     (when (eq chain-head (sod-class-chain-head class))
 517       (sequence-output (stream sequencer)
 518         ((class :vtable chain-head :slots)
 519          (format stream "  const ~A *~:[_class~;~:*_cls_~A~];~%"
 520                  metaclass
 521                  (and (sod-class-direct-superclasses meta-chain-head)
 522                       (sod-class-nickname meta-chain-head))))))))
 523
 524 (defmethod hook-output ((boff base-offset) (reason (eql :h)) sequencer)
 525   "Declare the member for the base offset within a `vtmsgs' structure."
 526   (with-slots ((class %class) chain-head) boff
 527     (when (eq chain-head (sod-class-chain-head class))
 528       (sequence-output (stream sequencer)
 529         ((class :vtable chain-head :slots)
 530          (write-line "  size_t _base;" stream))))))
 531
 532 (defmethod hook-output ((choff chain-offset) (reason (eql :h)) sequencer)
 533   "Declare the member for a cross-chain offset within a `vtmsgs' structure."
 534   (with-slots ((class %class) chain-head target-head) choff
 535     (when (eq chain-head (sod-class-chain-head class))
 536       (sequence-output (stream sequencer)
 537         ((class :vtable chain-head :slots)
 538          (format stream "  ptrdiff_t _off_~A;~%"
 539                  (sod-class-nickname target-head)))))))
 540
 541 ;;;--------------------------------------------------------------------------
 542 ;;; Static instance declarations.
 543
 544 (export 'declare-static-instance)
 545 (defgeneric declare-static-instance (instance stream)
 546   (:documentation
 547    "Write a declaration for the static INSTANCE to STREAM.
 548
 549    Note that, according to whether the instance is external or private, this
 550    may be written as part of the `:h' or `:c' reasons."))
 551 (defmethod declare-static-instance (instance stream)
 552   (with-slots ((class %class) name externp constp) instance
 553     (format stream "~:[static~;extern~] ~:[~;const ~]struct ~
 554                       ~A ~A__instance;~%~
 555                     #define ~A (&~A__instance.~A.~A)~%"
 556             externp constp (ilayout-struct-tag class) name
 557             name name (sod-class-nickname (sod-class-chain-head class))
 558             (sod-class-nickname class))))
 559
 560 (defmethod hook-output
 561     ((instance static-instance) (reason (eql :h)) sequencer)
 562   "Write an `extern' declaration for an external static instance."
 563   (with-slots (externp) instance
 564     (when externp
 565       (one-off-output 'static-instances-banner sequencer
 566                       '(:static-instances :start)
 567                       (lambda (stream)
 568                         (banner "Public static instances" stream)))
 569       (one-off-output 'static-instances-end sequencer
 570                       '(:static-instances :end)
 571                       #'terpri)
 572       (sequence-output (stream sequencer)
 573         (:static-instances
 574          (declare-static-instance instance stream))))))
 575
 576 ;;;--------------------------------------------------------------------------
 577 ;;; Implementation output.
 578
 579 (export '*instance-class*)
 580 (defvar-unbound *instance-class*
 581   "The class currently being output.
 582
 583    This is bound during the `hook-output' traversal of a class layout for
 584    `:c' output, since some of the objects traversed actually `belong' to
 585    superclasses and there's no other way to find out what the reference class
 586    actually is.
 587
 588    It may be bound at other times.")
 589
 590 (defmethod hook-output ((class sod-class) (reason (eql :c)) sequencer)
 591   "Write the skeleton of a class definition.
 592
 593    Most of the work is done by other methods.
 594
 595      * The direct methods are defined by the `sod-method' objects.
 596
 597      * The effective method functions and related structures are defined by
 598        the effective method objects.
 599
 600      * The vtable structures are initialized by the vtable objects and their
 601        component items.
 602
 603      * The class structure and its associated tables are initialized by the
 604        metaclass's layout objects."
 605
 606   (sequence-output (stream sequencer)
 607
 608     :constraint
 609     ((:classes :start)
 610      (class :banner)
 611      (class :direct-methods :start) (class :direct-methods :end)
 612      (class :effective-methods)
 613      (class :vtables :start) (class :vtables :end)
 614      (class :object :prepare) (class :object :start) (class :object :end)
 615      (:classes :end))
 616
 617     ((class :banner)
 618      (banner (format nil "Class ~A" class) stream))
 619
 620     ((class :object :start)
 621      (format stream "~
 622 /* The class object. */
 623 const struct ~A ~A__classobj = {~%"
 624              (ilayout-struct-tag (sod-class-metaclass class))
 625              class))
 626     ((class :object :end)
 627      (format stream "};~2%"))))
 628
 629 (defmethod hook-output :after ((class sod-class) (reason (eql :c)) sequencer)
 630   "Register hooks to initialize the class object structure."
 631   (let ((*instance-class* class))
 632     (hook-output (sod-class-ilayout (sod-class-metaclass class))
 633                  'class sequencer)))
 634
 635 ;;;--------------------------------------------------------------------------
 636 ;;; Direct and effective methods.
 637
 638 (defmethod hook-output ((method delegating-direct-method)
 639                         (reason (eql :c)) sequencer)
 640   "Define the `CALL_NEXT_METHOD' macro around a `delegating-direct-method'."
 641   (with-slots ((class %class) body) method
 642     (unless body
 643       (return-from hook-output))
 644     (sequence-output (stream sequencer)
 645       ((class :direct-method method :start)
 646        (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
 647                (mapcar #'argument-name
 648                        (c-function-arguments (sod-method-next-method-type
 649                                               method)))))
 650       ((class :direct-method method :end)
 651        (format stream "#undef CALL_NEXT_METHOD~%"))))
 652   (call-next-method))
 653
 654 (defmethod hook-output ((method sod-method) (reason (eql :c)) sequencer)
 655   "Define a direct method function."
 656   (with-slots ((class %class) role body message) method
 657     (unless body
 658       (return-from hook-output))
 659     (sequence-output (stream sequencer)
 660       :constraint ((class :direct-methods :start)
 661                    (class :direct-method method :banner)
 662                    (class :direct-method method :start)
 663                    (class :direct-method method :body)
 664                    (class :direct-method method :end)
 665                    (class :direct-methods :end))
 666       ((class :direct-method method :banner)
 667        (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~
 668                                       on `~A.~A' ~:_defined by `~A'."
 669                               role
 670                               (sod-class-nickname
 671                                (sod-message-class message))
 672                               (sod-message-name message)
 673                               class)
 674        (fresh-line stream))
 675       ((class :direct-method method :body)
 676        (pprint-c-type (sod-method-function-type method)
 677                       stream
 678                       (sod-method-function-name method))
 679        (format stream "~&{~%")
 680        (write body :stream stream :pretty nil :escape nil)
 681        (format stream "~&}~%"))
 682       ((class :direct-method method :end)
 683        (terpri stream)))))
 684
 685 (defmethod hook-output ((method basic-effective-method)
 686                         (reason (eql :c)) sequencer)
 687   "Define an effective method's functions.
 688
 689    Specifically, the method-entry functions and any auxiliary functions
 690    needed to stitch everything together."
 691   (with-slots ((class %class) functions) method
 692     (sequence-output (stream sequencer)
 693       ((class :effective-methods)
 694        (let* ((keys (effective-method-keywords method))
 695               (message (effective-method-message method))
 696               (msg-class (sod-message-class message)))
 697          (when keys
 698            (format-banner-comment stream "Keyword argument structure ~:_~
 699                                           for `~A.~A' ~:_on class `~A'."
 700                                   (sod-class-nickname msg-class)
 701                                   (sod-message-name message)
 702                                   class)
 703            (format stream "~&struct ~A {~%"
 704                    (effective-method-keyword-struct-tag method))
 705            (format stream "~{  unsigned ~A__suppliedp: 1;~%~}"
 706                    (mapcar #'argument-name keys))
 707            (dolist (key keys)
 708              (write-string "  " stream)
 709              (pprint-c-type (argument-type key) stream (argument-name key))
 710              (format stream ";~%"))
 711            (format stream "};~2%")))
 712        (dolist (func functions)
 713          (write func :stream stream :escape nil :circle nil))))))
 714
 715 ;;;--------------------------------------------------------------------------
 716 ;;; Vtables.
 717
 718 (defmethod hook-output ((vtable vtable) (reason (eql :c)) sequencer)
 719   "Define a vtable structure.
 720
 721    Here we just provide the outermost structure.  It gets filled in by the
 722    vtable object's body items."
 723   (with-slots ((class %class) chain-head chain-tail) vtable
 724     (sequence-output (stream sequencer)
 725       :constraint ((class :vtables :start)
 726                    (class :vtable chain-head :start)
 727                    (class :vtable chain-head :end)
 728                    (class :vtables :end))
 729       ((class :vtable chain-head :start)
 730        (format stream "/* Vtable for ~A chain. */~@
 731                        const union ~A ~A = { {~%"
 732                chain-head
 733                (vtable-union-tag chain-tail chain-head)
 734                (vtable-name class chain-head)))
 735       ((class :vtable chain-head :end)
 736        (format stream "} };~2%")))))
 737
 738 (defmethod hook-output ((cptr class-pointer) (reason (eql :c)) sequencer)
 739   "Drop a class pointer into a vtable definition."
 740   (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
 741     (sequence-output (stream sequencer)
 742       :constraint ((class :vtable chain-head :start)
 743                    (class :vtable chain-head :class-pointer metaclass)
 744                    (class :vtable chain-head :end))
 745       ((class :vtable chain-head :class-pointer metaclass)
 746        (format stream "  /* ~21@A = */ &~A__classobj.~A.~A,~%"
 747                (if (sod-class-direct-superclasses meta-chain-head)
 748                    (format nil "_cls_~A"
 749                            (sod-class-nickname meta-chain-head))
 750                    "_class")
 751                class
 752                (sod-class-nickname meta-chain-head)
 753                (sod-class-nickname metaclass))))))
 754
 755 (defmethod hook-output ((boff base-offset) (reason (eql :c)) sequencer)
 756   "Drop a base offset into a vtable definition."
 757   (with-slots ((class %class) chain-head) boff
 758     (sequence-output (stream sequencer)
 759       :constraint ((class :vtable chain-head :start)
 760                    (class :vtable chain-head :base-offset)
 761                    (class :vtable chain-head :end))
 762       ((class :vtable chain-head :base-offset)
 763        (format stream "  /* ~21@A = */ offsetof(struct ~A, ~A),~%"
 764                "_base"
 765                (ilayout-struct-tag class)
 766                (sod-class-nickname chain-head))))))
 767
 768 (defmethod hook-output ((choff chain-offset) (reason (eql :c)) sequencer)
 769   "Drop a cross-chain offset into a vtable definition."
 770   (with-slots ((class %class) chain-head target-head) choff
 771     (sequence-output (stream sequencer)
 772       :constraint ((class :vtable chain-head :start)
 773                    (class :vtable chain-head :chain-offset target-head)
 774                    (class :vtable chain-head :end))
 775       ((class :vtable chain-head :chain-offset target-head)
 776        (format stream "  /* ~21@A = */ SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
 777                (format nil "_off_~A" (sod-class-nickname target-head))
 778                (ilayout-struct-tag class)
 779                (sod-class-nickname chain-head)
 780                (sod-class-nickname target-head))))))
 781
 782 (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
 783   "Define the method entry pointers for a superclass's messages.
 784
 785    We only provide the outer structure.  It gets filled in by the
 786    `method-entry' objects."
 787   (with-slots ((class %class) subclass chain-head) vtmsgs
 788     (sequence-output (stream sequencer)
 789       :constraint ((subclass :vtable chain-head :start)
 790                    (subclass :vtable chain-head :vtmsgs class :start)
 791                    (subclass :vtable chain-head :vtmsgs class :slots)
 792                    (subclass :vtable chain-head :vtmsgs class :end)
 793                    (subclass :vtable chain-head :end))
 794       ((subclass :vtable chain-head :vtmsgs class :start)
 795        (format stream "  { /* Method entries for ~A messages. */~%"
 796                class))
 797       ((subclass :vtable chain-head :vtmsgs class :end)
 798        (format stream "  },~%")))))
 799
 800 (defmethod hook-output ((entry method-entry) (reason (eql :c)) sequencer)
 801   "Define a method-entry pointer in a vtable."
 802   (with-slots ((method %method) chain-head chain-tail role) entry
 803     (let* ((message (effective-method-message method))
 804            (class (effective-method-class method))
 805            (super (sod-message-class message)))
 806       (sequence-output (stream sequencer)
 807         ((class :vtable chain-head :vtmsgs super :slots)
 808          (format stream "    /* ~19@A = */ ~A,~%"
 809                  (method-entry-slot-name entry)
 810                  (method-entry-function-name method chain-head role)))))))
 811
 812 ;;;--------------------------------------------------------------------------
 813 ;;; Filling in the class object.
 814
 815 (defmethod hook-output ((ichain ichain) (reason (eql 'class)) sequencer)
 816   "Define an instance chain of a class object.
 817
 818    Here we only provide the outer structure.  It gets filled in by the
 819    `ichain' object's body items."
 820   (with-slots ((class %class) chain-head) ichain
 821     (sequence-output (stream sequencer)
 822       :constraint ((*instance-class* :object :start)
 823                    (*instance-class* :object chain-head :ichain :start)
 824                    (*instance-class* :object chain-head :ichain :end)
 825                    (*instance-class* :object :end))
 826       ((*instance-class* :object chain-head :ichain :start)
 827        (format stream "  { { /* ~A ichain */~%"
 828                (sod-class-nickname chain-head)))
 829       ((*instance-class* :object chain-head :ichain :end)
 830        (format stream "  } },~%")))))
 831
 832 (defmethod hook-output ((islots islots) (reason (eql 'class)) sequencer)
 833   "Define an instance's slots in a class object.
 834
 835    Here we only provide the outer structure.  It gets filled in by the
 836    individual slot objects."
 837   (with-slots ((class %class)) islots
 838     (let ((chain-head (sod-class-chain-head class)))
 839       (sequence-output (stream sequencer)
 840         :constraint ((*instance-class* :object chain-head :ichain :start)
 841                      (*instance-class* :object class :slots :start)
 842                      (*instance-class* :object class :slots)
 843                      (*instance-class* :object class :slots :end)
 844                      (*instance-class* :object chain-head :ichain :end))
 845         ((*instance-class* :object class :slots :start)
 846          (format stream "      { /* Class ~A */~%" class))
 847         ((*instance-class* :object class :slots :end)
 848          (format stream "      },~%"))))))
 849
 850 (defmethod hook-output ((vtptr vtable-pointer)
 851                         (reason (eql 'class)) sequencer)
 852   "Define a vtable pointer in a class object."
 853   (with-slots ((class %class) chain-head chain-tail) vtptr
 854     (sequence-output (stream sequencer)
 855       :constraint ((*instance-class* :object chain-head :ichain :start)
 856                    (*instance-class* :object chain-head :vtable)
 857                    (*instance-class* :object chain-head :ichain :end))
 858       ((*instance-class* :object chain-head :vtable)
 859        (format stream "      /* ~17@A = */ &~A.~A,~%"
 860                "_vt"
 861                (vtable-name class chain-head)
 862                (sod-class-nickname chain-tail))))))
 863
 864 (defgeneric output-class-initializer (slot instance stream)
 865   (:documentation
 866    "Define an individual slot in a class object.")
 867   (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
 868     "If this slot has an initializer function, then call it; otherwise try to
 869      find an initializer as usual."
 870     (let ((func (effective-slot-initializer-function slot))
 871           (direct-slot (effective-slot-direct-slot slot)))
 872       (if func
 873           (format stream "        /* ~15@A = */ ~A,~%"
 874                   (sod-slot-name direct-slot)
 875                   (funcall func instance))
 876           (call-next-method))))
 877   (:method ((slot effective-slot) (instance sod-class) stream)
 878     "Initialize a class slot by looking up an applicable initializer."
 879     (let ((init (find-class-initializer slot instance))
 880           (direct-slot (effective-slot-direct-slot slot)))
 881       (format stream "        /* ~15@A = */ ~A,~%"
 882               (sod-slot-name direct-slot)
 883               (sod-initializer-value init)))))
 884
 885 (defmethod hook-output ((slot sod-class-effective-slot)
 886                         (reason (eql 'class)) sequencer)
 887   "Write any necessary preparatory definitions for a class slot with a
 888    computed initializer."
 889   (let ((instance *instance-class*)
 890         (func (effective-slot-prepare-function slot)))
 891     (when func
 892       (sequence-output (stream sequencer)
 893         ((instance :object :prepare)
 894          (funcall func instance stream)))))
 895   (call-next-method))
 896
 897 (defmethod hook-output ((slot effective-slot)
 898                         (reason (eql 'class)) sequencer)
 899   "Define a slot in a class object."
 900   (with-slots ((class %class) (dslot slot)) slot
 901     (let ((instance *instance-class*)
 902           (super (sod-slot-class dslot)))
 903       (sequence-output (stream sequencer)
 904         ((instance :object super :slots)
 905          (output-class-initializer slot instance stream))))))
 906
 907 ;;;--------------------------------------------------------------------------
 908 ;;; Static instances.
 909
 910 (export '*static-instance*)
 911 (defvar-unbound *static-instance*
 912   "The static instance currently being output.
 913
 914    This is bound during the `hook-output' traversal of a static instance for
 915    `:c', since the slots traversed need to be able to look up initializers
 916    from the static instance definition.")
 917
 918 (defmethod hook-output ((instance static-instance)
 919                         (reason (eql :c)) sequencer)
 920   "Write a static instance definition."
 921   (with-slots (externp) instance
 922     (one-off-output 'static-instances-banner sequencer
 923                     '(:static-instances :start)
 924                     (lambda (stream)
 925                       (banner "Static instance definitions" stream)))
 926     (unless externp
 927       (one-off-output 'static-instances-forward sequencer
 928                       '(:static-instances :start)
 929                       (lambda (stream)
 930                         (format stream "/* Forward declarations. */~%")))
 931       (one-off-output 'static-instances-forward-gap sequencer
 932                       '(:static-instances :gap)
 933                       #'terpri)
 934       (sequence-output (stream sequencer)
 935         ((:static-instances :decls)
 936          (declare-static-instance instance stream))))))
 937
 938 (defmethod hook-output ((class sod-class)
 939                         (reason (eql 'static-instance)) sequencer)
 940   "Output the framing around a static instance initializer."
 941   (let ((instance *static-instance*))
 942     (with-slots ((class %class) name externp constp) instance
 943       (sequence-output (stream sequencer)
 944         :constraint ((:static-instances :gap)
 945                      (*static-instance* :start)
 946                      (*static-instance* :end)
 947                      (:static-instances :end))
 948         ((*static-instance* :start)
 949          (format stream "/* Static instance `~A'. */~%~
 950                        ~:[static ~;~]~:[~;const ~]~
 951                          struct ~A ~A__instance = {~%"
 952                  name
 953                  externp constp
 954                  (ilayout-struct-tag class) name))
 955         ((*static-instance* :end)
 956          (format stream "};~2%"))))))
 957
 958 (defmethod hook-output ((ichain ichain)
 959                         (reason (eql 'static-instance)) sequencer)
 960   "Output the initializer for an ichain."
 961   (with-slots ((class %class) chain-head chain-tail) ichain
 962     (sequence-output (stream sequencer)
 963       :constraint ((*static-instance* :start)
 964                    (*static-instance* :ichain chain-head :start)
 965                    (*static-instance* :ichain chain-head :end)
 966                    (*static-instance* :end))
 967       ((*static-instance* :ichain chain-head :start)
 968        (format stream "  { { /* ~A ichain */~%"
 969                (sod-class-nickname chain-head)))
 970       ((*static-instance* :ichain chain-head :end)
 971        (format stream "  } },~%")))))
 972
 973 (defmethod hook-output ((islots islots)
 974                         (reason (eql 'static-instance)) sequencer)
 975   "Initialize a static instance's slots."
 976   (with-slots ((class %class)) islots
 977     (let ((chain-head (sod-class-chain-head class)))
 978       (sequence-output (stream sequencer)
 979         :constraint
 980         ((*static-instance* :ichain chain-head :start)
 981          (*static-instance* :slots class :start)
 982          (*static-instance* :slots class)
 983          (*static-instance* :slots class :end)
 984          (*static-instance* :ichain chain-head :end))
 985         ((*static-instance* :slots class :start)
 986          (format stream "      { /* Class ~A */~%" class))
 987         ((*static-instance* :slots class :end)
 988          (format stream "      },~%"))))))
 989
 990 (defmethod hook-output ((vtptr vtable-pointer)
 991                         (reason (eql 'static-instance)) sequencer)
 992   "Initialize a vtable pointer in a static instance.."
 993   (with-slots ((class %class) chain-head chain-tail) vtptr
 994     (sequence-output (stream sequencer)
 995       :constraint ((*static-instance* :ichain chain-head :start)
 996                    (*static-instance* :vtable chain-head)
 997                    (*static-instance* :ichain chain-head :end))
 998       ((*static-instance* :vtable chain-head)
 999        (format stream "      /* ~17@A = */ &~A.~A,~%"
1000                "_vt"
1001                (vtable-name class chain-head)
1002                (sod-class-nickname chain-tail))))))
1003
1004 (export 'output-static-instance-initializer)
1005 (defgeneric output-static-instance-initializer (instance slot stream)
1006   (:documentation
1007    "Output an initializer for an effective SLOT in a static INSTANCE."))
1008 (defmethod output-static-instance-initializer ((instance static-instance)
1009                                                (slot effective-slot)
1010                                                stream)
1011   (let* ((direct-slot (effective-slot-direct-slot slot))
1012          (init (or (find direct-slot
1013                          (static-instance-initializers instance)
1014                          :key #'sod-initializer-slot)
1015                    (effective-slot-initializer slot))))
1016     (format stream "        /* ~15@A = */ ~A,~%"
1017             (sod-slot-name direct-slot)
1018             (sod-initializer-value init))))
1019
1020 (defmethod hook-output ((slot effective-slot)
1021                         (reason (eql 'static-instance)) sequencer)
1022   "Initialize a slot in a static instance."
1023   (with-slots ((class %class) initializers) *static-instance*
1024     (with-slots ((dslot slot)) slot
1025       (let ((super (sod-slot-class dslot))
1026             (instance *static-instance*))
1027       (sequence-output (stream sequencer)
1028         ((instance :slots super)
1029          (output-static-instance-initializer instance slot stream)))))))
1030
1031 (defmethod hook-output :after
1032     ((instance static-instance) (reason (eql :c)) sequencer)
1033   (with-slots ((class %class)) instance
1034     (let ((*static-instance* instance))
1035       (hook-output class 'static-instance sequencer))))
1036
1037 ;;;----- That's all, folks --------------------------------------------------