[sod] / src / class-output.lisp

;;; -*-lisp-*-
;;;
;;; Output for classes
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Walking the layout tree.

(defmethod hook-output :after ((class sod-class) reason sequencer)
  "Register hooks for the class layout, direct methods, effective methods,
   and vtables."
  (with-slots ((ilayout %ilayout) vtables methods effective-methods) class
    (hook-output ilayout reason sequencer)
    (dolist (method methods) (hook-output method reason sequencer))
    (dolist (method effective-methods) (hook-output method reason sequencer))
    (dolist (vtable vtables) (hook-output vtable reason sequencer))))

(defmethod hook-output :after ((ilayout ilayout) reason sequencer)
  "Register hooks for the layout's ichains."
  (with-slots (ichains) ilayout
    (dolist (ichain ichains) (hook-output ichain reason sequencer))))

(defmethod hook-output :after ((ichain ichain) reason sequencer)
  "Register hooks for the ichain body's items."
  (dolist (item (ichain-body ichain)) (hook-output item reason sequencer)))

(defmethod hook-output :after ((islots islots) reason sequencer)
  "Register hooks for the islots structure's individual slots."
  (dolist (slot (islots-slots islots)) (hook-output slot reason sequencer)))

(defmethod hook-output :after ((vtable vtable) reason sequencer)
  "Register hooks for the vtable body's items."
  (with-slots (body) vtable
    (dolist (item body) (hook-output item reason sequencer))))

(defmethod hook-output :after ((vtmsgs vtmsgs) reason sequencer)
  "Register hooks for the vtmsgs structure's individual method entries."
  (with-slots (entries) vtmsgs
    (dolist (entry entries) (hook-output entry reason sequencer))))

;;;--------------------------------------------------------------------------
;;; Class declarations.

(export 'emit-class-typedef)
(defgeneric emit-class-typedef (class stream)
  (:documentation
   "Emit a `typedef' for the CLASS's C class type to the output STREAM.

   By default, this will be an alias for the class's home `ichain'
   structure."))
(defmethod emit-class-typedef ((class sod-class) stream)
  (format stream "typedef struct ~A ~A;~%"
	  (ichain-struct-tag class (sod-class-chain-head class)) class))

(export 'emit-class-object-decl)
(defgeneric emit-class-object-decl (class stream)
  (:documentation
   "Emit the declaration and macros for the CLASS's class object.

   This includes the main declaration, and the convenience macros for
   referring to the class object's individual chains.  Write everything to
   the output STREAM."))
(defmethod emit-class-object-decl ((class sod-class) stream)
  (let ((metaclass (sod-class-metaclass class))
	(metaroot (find-root-metaclass class)))

    ;; Output the actual class object declaration, and the special
    ;; `...__class' macro for the root-metaclass chain.
    (format stream "/* The class object. */~@
		    extern const struct ~A ~A__classobj;~@
		    #define ~:*~A__class (&~:*~A__classobj.~A.~A)~%"
	    (ilayout-struct-tag metaclass) class
	    (sod-class-nickname (sod-class-chain-head metaroot))
	    (sod-class-nickname metaroot))

    ;; Write the uglier `...__cls_...' macros for the class object's other
    ;; chains, if any.
    (dolist (chain (sod-class-chains metaclass))
      (let ((tail (car chain)))
	(unless (eq tail metaroot)
	  (format stream "#define ~A__cls_~A (&~2:*~A__classobj.~A.~A)~%"
		  class (sod-class-nickname (sod-class-chain-head tail))
		  (sod-class-nickname tail)))))
    (terpri stream)))

(export 'emit-class-conversion-macro)
(defgeneric emit-class-conversion-macro (class super stream)
  (:documentation
   "Emit a macro for converting an instance of CLASS to an instance of SUPER.

   By default this is named `CLASS__CONV_SPR'.  In-chain upcasts are just a
   trivial pointer cast, which any decent compiler will elide; cross-chain
   upcasts use the `SOD_XCHAIN' macro.  Write the macro to the output
   STREAM."))
(defmethod emit-class-conversion-macro
    ((class sod-class) (super sod-class) stream)
  (let ((super-head (sod-class-chain-head super)))
    (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~
		    ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%"
	    class (sod-class-nickname super) super
	    (eq super-head (sod-class-chain-head class))
	    (sod-class-nickname super-head))))

(export 'emit-message-macro-defn)
(defgeneric emit-message-macro-defn
    (class entry varargsp me in-names out-names stream)
  (:documentation
   "Output a message macro for invoking a method ENTRY, with given arguments.

   The default method on `emit-message-macro' calcualates the necessary
   argument lists and calls this function to actually write the necessary
   `#define' line to the stream.  The intended division of responsibilities
   is that `emit-message-macro' handles the peculiarities of marshalling the
   arguments to the method entry function, while `emit-message-macro-defn'
   concerns itself with navigating the vtable to find the right function in
   the first place.")
  (:method :around ((class sod-class) (entry method-entry)
		    varargsp me in-names out-names
		    stream)
    (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
    (call-next-method)
    (when varargsp (format stream "#endif~%"))))
(defmethod emit-message-macro-defn ((class sod-class) (entry method-entry)
				    varargsp me in-names out-names
				    stream)
  (format stream "#define ~A(~{~A~^, ~}) (~A)->_vt->~A.~A(~{~A~^, ~})~%"
	  (message-macro-name class entry)
	  in-names
	  me
	  (sod-class-nickname class)
	  (method-entry-slot-name entry)
	  out-names))

(export 'emit-message-macro)
(defgeneric emit-message-macro (class entry stream)
  (:documentation
   "Write a macro for invoking the method ENTRY on an instance of CLASS.

   The default behaviour is quite complicated, particular when varargs or
   keyword messages are involved."))
(defmethod emit-message-macro ((class sod-class) (entry method-entry) stream)
  (when (some (lambda (message)
		(or (keyword-message-p message)
		    (varargs-message-p message)))
	      (sod-class-messages class)))
  (let* ((type (method-entry-function-type entry))
	 (args (c-function-arguments type))
	 (in-names nil) (out-names nil) (varargsp nil) (me "me"))
    (do ((args args (cdr args)))
	((endp args))
      (let* ((raw-name (princ-to-string (argument-name (car args))))
	     (name (if (find raw-name
			     (list "_vt"
				   (sod-class-nickname class)
				   (method-entry-slot-name entry))
			     :test #'string=)
		       (format nil "sod__a_~A" raw-name)
		       raw-name)))
	(cond ((and (cdr args) (eq (cadr args) :ellipsis))
	       (setf varargsp t)
	       (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
	       (push (format nil "/*~A*/ ..." name) in-names)
	       (push "__VA_ARGS__" out-names)
	       (return))
	      (t
	       (push name in-names)
	       (push name out-names)))))
    (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
    (emit-message-macro-defn class entry varargsp me
			     (nreverse in-names)
			     (nreverse out-names)
			     stream)
    (when varargsp (format stream "#endif~%"))))

(defmethod hook-output ((class sod-class) (reason (eql :h)) sequencer)
  "Write the skeleton of a class declaration.

   Most of the work is done by other functions.

     * The class type is defined by `emit-class-typedef'.

     * The class object is declared by `emit-class-object-decl'.

     * The upcast conversion macros are defined by `emit-class-conversion-
       macro'.

     * The message invocation macros are defined by `emit-message-macro'.

     * The class instance structure itself is constructed by the `ilayout'
       object.

     * The various vtable structures are constructed by the `vtable'
       objects."

  ;; Main output sequencing.
  (sequence-output (stream sequencer)

    :constraint
    ((:classes :start)
     (class :banner)
     (class :islots :start) (class :islots :slots) (class :islots :end)
     (class :vtmsgs :start) (class :vtmsgs :end)
     (class :vtables :start) (class :vtables :end)
     (class :vtable-externs) (class :vtable-externs-after)
     (class :methods :start) (class :methods :defs)
     (class :methods) (class :methods :end)
     (class :ichains :start) (class :ichains :end)
     (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
     (class :conversions)
     (class :message-macros)
     (class :object)
     (:classes :end))

    (:typedefs (emit-class-typedef class stream))
    ((class :banner) (banner (format nil "Class ~A" class) stream))
    ((class :vtable-externs-after) (terpri stream))
    ((class :vtable-externs) (format stream "/* Vtable structures. */~%"))
    ((class :object) (emit-class-object-decl class stream)))

  ;; Maybe generate an islots structure.
  (when (sod-class-slots class)
    (sequence-output (stream sequencer)
      ((class :islots :start)
       (format stream "/* Instance slots. */~@
		       struct ~A {~%"
	       (islots-struct-tag class)))
      ((class :islots :end)
       (format stream "};~2%"))))

  ;; Declare the direct methods.
  (when (sod-class-methods class)
    (sequence-output (stream sequencer)
      ((class :methods :start)
       (format stream "/* Direct methods. */~%"))
      ((class :methods :end)
       (terpri stream))))

  ;; Provide upcast macros which do the right thing.
  (when (sod-class-direct-superclasses class)
    (sequence-output (stream sequencer)
      ((class :conversions)
       (format stream "/* Conversion macros. */~%")
       (dolist (super (cdr (sod-class-precedence-list class)))
	 (emit-class-conversion-macro class super stream))
       (terpri stream))))

  ;; Provide convenience macros for sending the newly defined messages.  (The
  ;; macros work on all subclasses too.)
  ;;
  ;; We need each message's method entry type for this, so we need to dig it
  ;; out of the vtmsgs structure.  Indeed, the vtmsgs for this class contains
  ;; entries for precisely the messages we want to make macros for.
  (when (some (lambda (message)
		(or (keyword-message-p message)
		    (varargs-message-p message)))
	      (sod-class-messages class))
    (one-off-output 'varargs-macros sequencer :early-decls
		    (lambda (stream)
		      (format stream
			      "~%SOD__VARARGS_MACROS_PREAMBLE~%"))))
  (when (sod-class-messages class)
    (sequence-output (stream sequencer)
      ((class :message-macros)
       (let* ((vtable (find (sod-class-chain-head class)
			    (sod-class-vtables class)
			    :key #'vtable-chain-head))
	      (vtmsgs (find-if (lambda (item)
				 (and (typep item 'vtmsgs)
				      (eql (vtmsgs-class item) class)))
			       (vtable-body vtable))))
	 (format stream "/* Message invocation macros. */~%")
	 (dolist (entry (vtmsgs-entries vtmsgs))
	   (emit-message-macro class entry stream))
	 (terpri stream))))))

(defmethod hook-output :after ((class sod-class) (reason (eql :h)) sequencer)
  "Register hooks to output CLASS's direct slots and messages."

  ;; Output a structure member definition for each instance slot.
  (dolist (slot (sod-class-slots class))
    (hook-output slot 'islots sequencer))

  ;; Generate a vtmsgs structure for all superclasses.
  (hook-output (car (sod-class-vtables class)) 'vtmsgs sequencer))

;;;--------------------------------------------------------------------------
;;; Instance structure.

(defmethod hook-output ((slot sod-slot) (reason (eql 'islots)) sequencer)
  "Declare the member for an individual slot within an `islots' structure."
  (sequence-output (stream sequencer)
    (((sod-slot-class slot) :islots :slots)
     (pprint-logical-block (stream nil :prefix "  " :suffix ";")
       (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
     (terpri stream))))

(defmethod hook-output ((ilayout ilayout) (reason (eql :h)) sequencer)
  "Define the structure for a class layout.

   Here we just provide the outermost structure.  It gets filled in by
   the `ichains' objects and their body items."
  (with-slots ((class %class) ichains) ilayout
    (sequence-output (stream sequencer)
      ((class :ilayout :start)
       (format stream "/* Instance layout. */~@
		       struct ~A {~%"
	       (ilayout-struct-tag class)))
      ((class :ilayout :end)
       (format stream "};~2%")))))

(defmethod hook-output :after ((ilayout ilayout) (reason (eql :h)) sequencer)
  "Register hooks to write chain members into the overall class layout."
  (dolist (ichain (ilayout-ichains ilayout))
    (hook-output ichain 'ilayout sequencer)))

(defmethod hook-output ((ichain ichain) (reason (eql :h)) sequencer)
  "Define the layout structure for a particular chain of a class.

   A member of this class is dropped into the `ilayout' structure by the
   corresponding method for the `ilayout' reason.

   We define both the chain structure of the class, and a union of it with
   all of its in-chain superclasses (so as to invoke the common-prefix
   rule)."
  (with-slots ((class %class) chain-head chain-tail) ichain
    (when (eq class chain-tail)
      (sequence-output (stream sequencer)
	:constraint ((class :ichains :start)
		     (class :ichain chain-head :start)
		     (class :ichain chain-head :slots)
		     (class :ichain chain-head :end)
		     (class :ichains :end))
	((class :ichain chain-head :start)
	 (format stream "/* Instance chain structure. */~@
			 struct ~A {~%"
		 (ichain-struct-tag chain-tail chain-head)))
	((class :ichain chain-head :end)
	 (format stream "};~2%")
	 (format stream "/* Union of equivalent superclass chains. */~@
			 union ~A {~@
			 ~:{  struct ~A ~A;~%~}~
			 };~2%"
		 (ichain-union-tag chain-tail chain-head)

		 ;; Make sure the most specific class is first: only the
		 ;; first element of a union can be statically initialized in
		 ;; C90.
		 (mapcar (lambda (super)
			   (list (ichain-struct-tag super chain-head)
				 (sod-class-nickname super)))
			 (sod-class-chain chain-tail))))))))

(defmethod hook-output ((ichain ichain) (reason (eql 'ilayout)) sequencer)
  "Declare the member for a class chain within the class layout."
  (with-slots ((class %class) chain-head chain-tail) ichain
    (sequence-output (stream sequencer)
      ((class :ilayout :slots)
       (format stream "  union ~A ~A;~%"
	       (ichain-union-tag chain-tail chain-head)
	       (sod-class-nickname chain-head))))))

(defmethod hook-output ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
  "Declare the member for a vtable pointer within an `ichain' structure."
  (with-slots ((class %class) chain-head chain-tail) vtptr
    (when (eq class chain-tail)
      (sequence-output (stream sequencer)
	((class :ichain chain-head :slots)
	 (format stream "  const struct ~A *_vt;~%"
		 (vtable-struct-tag chain-tail chain-head)))))))

(defmethod hook-output ((islots islots) (reason (eql :h)) sequencer)
  "Declare the member for a class's `islots' within an `ichain' structure."
  (with-slots ((class %class) subclass slots) islots
    (let ((head (sod-class-chain-head class)))
      (when (eq head (sod-class-chain-head subclass))
	(sequence-output (stream sequencer)
	  ((subclass :ichain (sod-class-chain-head class) :slots)
	   (format stream "  struct ~A ~A;~%"
		   (islots-struct-tag class)
		   (sod-class-nickname class))))))))

;;;--------------------------------------------------------------------------
;;; Vtable structure.

(defmethod hook-output ((method sod-method) (reason (eql :h)) sequencer)
  "Emit declarations for a direct method.

   We declare the direct method function, and, if necessary, the `suppliedp'
   structure for its keyword arguments."

  (with-slots ((class %class)) method
    (sequence-output (stream sequencer)
      ((class :methods)
       (let ((type (sod-method-function-type method)))
	 (princ "extern " stream)
	 (pprint-c-type (commentify-function-type type) stream
			(sod-method-function-name method))
	 (format stream ";~%")))
      ((class :methods :defs)
       (let* ((type (sod-method-type method))
	      (keys (and (typep type 'c-keyword-function-type)
			 (c-function-keywords type))))
	 (when keys
	   (format stream "struct ~A {~%~
			   ~{  unsigned ~A: 1;~%~}~
			   };~2%"
		   (direct-method-suppliedp-struct-tag method)
		   (mapcar #'argument-name keys))))))))

(defmethod hook-output ((vtable vtable) (reason (eql :h)) sequencer)
  "Define the structure for a vtable.

   We define the vtable structure of the class, and a union of it with all of
   its in-chain superclasses (so as to invoke the common-prefix rule).  We
   also declare the vtable object, defined by the corresponding `:c' method."
  (with-slots ((class %class) chain-head chain-tail) vtable
    (when (eq class chain-tail)
      (sequence-output (stream sequencer)
	:constraint ((class :vtables :start)
		     (class :vtable chain-head :start)
		     (class :vtable chain-head :slots)
		     (class :vtable chain-head :end)
		     (class :vtables :end))
	((class :vtable chain-head :start)
	 (format stream "/* Vtable structure. */~@
			 struct ~A {~%"
		 (vtable-struct-tag chain-tail chain-head)))
	((class :vtable chain-head :end)
	 (format stream "};~2%")
	 (format stream "/* Union of equivalent superclass vtables. */~@
			 union ~A {~@
			 ~:{  struct ~A ~A;~%~}~
			 };~2%"
		 (vtable-union-tag chain-tail chain-head)

		 ;; As for the ichain union, make sure the most specific
		 ;; class is first.
		 (mapcar (lambda (super)
			   (list (vtable-struct-tag super chain-head)
				 (sod-class-nickname super)))
			 (sod-class-chain chain-tail))))))
    (sequence-output (stream sequencer)
      ((class :vtable-externs)
       (format stream "~@<extern const union ~A ~2I~_~A;~:>~%"
	       (vtable-union-tag chain-tail chain-head)
	       (vtable-name class chain-head))))))

(defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
  "Declare the member for a class's `vtmsgs' within a `vtable' structure."
  (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs
    (when (eq subclass chain-tail)
      (sequence-output (stream sequencer)
	((subclass :vtable chain-head :slots)
	 (format stream "  struct ~A ~A;~%"
		 (vtmsgs-struct-tag subclass class)
		 (sod-class-nickname class)))))))

(defmethod hook-output ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer)
  "Define the `vtmsgs' structure for a class's method entry functions."
  (when (vtmsgs-entries vtmsgs)
    (with-slots ((class %class) subclass) vtmsgs
      (sequence-output (stream sequencer)
	:constraint ((subclass :vtmsgs :start)
		     (subclass :vtmsgs class :start)
		     (subclass :vtmsgs class :slots)
		     (subclass :vtmsgs class :end)
		     (subclass :vtmsgs :end))
	((subclass :vtmsgs class :start)
	 (format stream "/* Messages protocol from class ~A */~@
			 struct ~A {~%"
		 class
		 (vtmsgs-struct-tag subclass class)))
	((subclass :vtmsgs class :end)
	 (format stream "};~2%"))))))

(defmethod hook-output ((entry method-entry)
			(reason (eql 'vtmsgs)) sequencer)
  "Declare the member for a method entry within a `vtmsgs' structure."
  (let* ((method (method-entry-effective-method entry))
	 (message (effective-method-message method))
	 (class (effective-method-class method))
	 (function-type (method-entry-function-type entry))
	 (commented-type (commentify-function-type function-type))
	 (pointer-type (make-pointer-type commented-type)))
    (sequence-output (stream sequencer)
      ((class :vtmsgs (sod-message-class message) :slots)
       (pprint-logical-block (stream nil :prefix "  " :suffix ";")
	 (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
       (terpri stream)))))

(defmethod hook-output ((cptr class-pointer) (reason (eql :h)) sequencer)
  "Declare the member for a class-chain pointer within a `vtmsgs' structure."
  (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
    (when (eq chain-head (sod-class-chain-head class))
      (sequence-output (stream sequencer)
	((class :vtable chain-head :slots)
	 (format stream "  const ~A *~:[_class~;~:*_cls_~A~];~%"
		 metaclass
		 (and (sod-class-direct-superclasses meta-chain-head)
		      (sod-class-nickname meta-chain-head))))))))

(defmethod hook-output ((boff base-offset) (reason (eql :h)) sequencer)
  "Declare the member for the base offset within a `vtmsgs' structure."
  (with-slots ((class %class) chain-head) boff
    (when (eq chain-head (sod-class-chain-head class))
      (sequence-output (stream sequencer)
	((class :vtable chain-head :slots)
	 (write-line "  size_t _base;" stream))))))

(defmethod hook-output ((choff chain-offset) (reason (eql :h)) sequencer)
  "Declare the member for a cross-chain offset within a `vtmsgs' structure."
  (with-slots ((class %class) chain-head target-head) choff
    (when (eq chain-head (sod-class-chain-head class))
      (sequence-output (stream sequencer)
	((class :vtable chain-head :slots)
	 (format stream "  ptrdiff_t _off_~A;~%"
		 (sod-class-nickname target-head)))))))

;;;--------------------------------------------------------------------------
;;; Implementation output.

(export '*instance-class*)
(defvar-unbound *instance-class*
  "The class currently being output.

   This is bound during the `hook-output' traversal of a class layout for
   `:c' output, since some of the objects traversed actually `belong' to
   superclasses and there's no other way to find out what the reference class
   actually is.

   It may be bound at other times.")

(defmethod hook-output ((class sod-class) (reason (eql :c)) sequencer)
  "Write the skeleton of a class definition.

   Most of the work is done by other methods.

     * The direct methods are defined by the `sod-method' objects.

     * The effective method functions and related structures are defined by
       the effective method objects.

     * The vtable structures are initialized by the vtable objects and their
       component items.

     * The class structure and its associated tables are initialized by the
       metaclass's layout objects."

  (sequence-output (stream sequencer)

    :constraint
    ((:classes :start)
     (class :banner)
     (class :direct-methods :start) (class :direct-methods :end)
     (class :effective-methods)
     (class :vtables :start) (class :vtables :end)
     (class :object :prepare) (class :object :start) (class :object :end)
     (:classes :end))

    ((class :banner)
     (banner (format nil "Class ~A" class) stream))

    ((class :object :start)
     (format stream "~
/* The class object. */
const struct ~A ~A__classobj = {~%"
	     (ilayout-struct-tag (sod-class-metaclass class))
	     class))
    ((class :object :end)
     (format stream "};~2%"))))

(defmethod hook-output :after ((class sod-class) (reason (eql :c)) sequencer)
  "Register hooks to initialize the class object structure."
  (let ((*instance-class* class))
    (hook-output (sod-class-ilayout (sod-class-metaclass class))
		 'class sequencer)))

;;;--------------------------------------------------------------------------
;;; Direct and effective methods.

(defmethod hook-output ((method delegating-direct-method)
			(reason (eql :c)) sequencer)
  "Define the `CALL_NEXT_METHOD' macro around a `delegating-direct-method'."
  (with-slots ((class %class) body) method
    (unless body
      (return-from hook-output))
    (sequence-output (stream sequencer)
      ((class :direct-method method :start)
       (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
	       (mapcar #'argument-name
		       (c-function-arguments (sod-method-next-method-type
					      method)))))
      ((class :direct-method method :end)
       (format stream "#undef CALL_NEXT_METHOD~%"))))
  (call-next-method))

(defmethod hook-output ((method sod-method) (reason (eql :c)) sequencer)
  "Define a direct method function."
  (with-slots ((class %class) role body message) method
    (unless body
      (return-from hook-output))
    (sequence-output (stream sequencer)
      :constraint ((class :direct-methods :start)
		   (class :direct-method method :banner)
		   (class :direct-method method :start)
		   (class :direct-method method :body)
		   (class :direct-method method :end)
		   (class :direct-methods :end))
      ((class :direct-method method :banner)
       (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~
				      on `~A.~A' ~:_defined by `~A'."
			      role
			      (sod-class-nickname
			       (sod-message-class message))
			      (sod-message-name message)
			      class)
       (fresh-line stream))
      ((class :direct-method method :body)
       (pprint-c-type (sod-method-function-type method)
		      stream
		      (sod-method-function-name method))
       (format stream "~&{~%")
       (write body :stream stream :pretty nil :escape nil)
       (format stream "~&}~%"))
      ((class :direct-method method :end)
       (terpri stream)))))

(defmethod hook-output ((method basic-effective-method)
			(reason (eql :c)) sequencer)
  "Define an effective method's functions.

   Specifically, the method-entry functions and any auxiliary functions
   needed to stitch everything together."
  (with-slots ((class %class) functions) method
    (sequence-output (stream sequencer)
      ((class :effective-methods)
       (let* ((keys (effective-method-keywords method))
	      (message (effective-method-message method))
	      (msg-class (sod-message-class message)))
	 (when keys
	   (format-banner-comment stream "Keyword argument structure ~:_~
					  for `~A.~A' ~:_on class `~A'."
				  (sod-class-nickname msg-class)
				  (sod-message-name message)
				  class)
	   (format stream "~&struct ~A {~%"
		   (effective-method-keyword-struct-tag method))
	   (format stream "~{  unsigned ~A__suppliedp: 1;~%~}"
		   (mapcar #'argument-name keys))
	   (dolist (key keys)
	     (write-string "  " stream)
	     (pprint-c-type (argument-type key) stream (argument-name key))
	     (format stream ";~%"))
	   (format stream "};~2%")))
       (dolist (func functions)
	 (write func :stream stream :escape nil :circle nil))))))

;;;--------------------------------------------------------------------------
;;; Vtables.

(defmethod hook-output ((vtable vtable) (reason (eql :c)) sequencer)
  "Define a vtable structure.

   Here we just provide the outermost structure.  It gets filled in by the
   vtable object's body items."
  (with-slots ((class %class) chain-head chain-tail) vtable
    (sequence-output (stream sequencer)
      :constraint ((class :vtables :start)
		   (class :vtable chain-head :start)
		   (class :vtable chain-head :end)
		   (class :vtables :end))
      ((class :vtable chain-head :start)
       (format stream "/* Vtable for ~A chain. */~@
		       const union ~A ~A = { {~%"
	       chain-head
	       (vtable-union-tag chain-tail chain-head)
	       (vtable-name class chain-head)))
      ((class :vtable chain-head :end)
       (format stream "} };~2%")))))

(defmethod hook-output ((cptr class-pointer) (reason (eql :c)) sequencer)
  "Drop a class pointer into a vtable definition."
  (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
    (sequence-output (stream sequencer)
      :constraint ((class :vtable chain-head :start)
		   (class :vtable chain-head :class-pointer metaclass)
		   (class :vtable chain-head :end))
      ((class :vtable chain-head :class-pointer metaclass)
       (format stream "  /* ~21@A = */ &~A__classobj.~A.~A,~%"
	       (if (sod-class-direct-superclasses meta-chain-head)
		   (format nil "_cls_~A"
			   (sod-class-nickname meta-chain-head))
		   "_class")
	       class
	       (sod-class-nickname meta-chain-head)
	       (sod-class-nickname metaclass))))))

(defmethod hook-output ((boff base-offset) (reason (eql :c)) sequencer)
  "Drop a base offset into a vtable definition."
  (with-slots ((class %class) chain-head) boff
    (sequence-output (stream sequencer)
      :constraint ((class :vtable chain-head :start)
		   (class :vtable chain-head :base-offset)
		   (class :vtable chain-head :end))
      ((class :vtable chain-head :base-offset)
       (format stream "  /* ~21@A = */ offsetof(struct ~A, ~A),~%"
	       "_base"
	       (ilayout-struct-tag class)
	       (sod-class-nickname chain-head))))))

(defmethod hook-output ((choff chain-offset) (reason (eql :c)) sequencer)
  "Drop a cross-chain offset into a vtable definition."
  (with-slots ((class %class) chain-head target-head) choff
    (sequence-output (stream sequencer)
      :constraint ((class :vtable chain-head :start)
		   (class :vtable chain-head :chain-offset target-head)
		   (class :vtable chain-head :end))
      ((class :vtable chain-head :chain-offset target-head)
       (format stream "  /* ~21@A = */ SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
	       (format nil "_off_~A" (sod-class-nickname target-head))
	       (ilayout-struct-tag class)
	       (sod-class-nickname chain-head)
	       (sod-class-nickname target-head))))))

(defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
  "Define the method entry pointers for a superclass's messages.

   We only provide the outer structure.  It gets filled in by the
   `method-entry' objects."
  (with-slots ((class %class) subclass chain-head) vtmsgs
    (sequence-output (stream sequencer)
      :constraint ((subclass :vtable chain-head :start)
		   (subclass :vtable chain-head :vtmsgs class :start)
		   (subclass :vtable chain-head :vtmsgs class :slots)
		   (subclass :vtable chain-head :vtmsgs class :end)
		   (subclass :vtable chain-head :end))
      ((subclass :vtable chain-head :vtmsgs class :start)
       (format stream "  { /* Method entries for ~A messages. */~%"
	       class))
      ((subclass :vtable chain-head :vtmsgs class :end)
       (format stream "  },~%")))))

(defmethod hook-output ((entry method-entry) (reason (eql :c)) sequencer)
  "Define a method-entry pointer in a vtable."
  (with-slots ((method %method) chain-head chain-tail role) entry
    (let* ((message (effective-method-message method))
	   (class (effective-method-class method))
	   (super (sod-message-class message)))
      (sequence-output (stream sequencer)
	((class :vtable chain-head :vtmsgs super :slots)
	 (format stream "    /* ~19@A = */ ~A,~%"
		 (method-entry-slot-name entry)
		 (method-entry-function-name method chain-head role)))))))

;;;--------------------------------------------------------------------------
;;; Filling in the class object.

(defmethod hook-output ((ichain ichain) (reason (eql 'class)) sequencer)
  "Define an instance chain of a class object.

   Here we only provide the outer structure.  It gets filled in by the
   `ichain' object's body items."
  (with-slots ((class %class) chain-head) ichain
    (sequence-output (stream sequencer)
      :constraint ((*instance-class* :object :start)
		   (*instance-class* :object chain-head :ichain :start)
		   (*instance-class* :object chain-head :ichain :end)
		   (*instance-class* :object :end))
      ((*instance-class* :object chain-head :ichain :start)
       (format stream "  { { /* ~A ichain */~%"
	       (sod-class-nickname chain-head)))
      ((*instance-class* :object chain-head :ichain :end)
       (format stream "  } },~%")))))

(defmethod hook-output ((islots islots) (reason (eql 'class)) sequencer)
  "Define an instance's slots in a class object.

   Here we only provide the outer structure.  It gets filled in by the
   individual slot objects."
  (with-slots ((class %class)) islots
    (let ((chain-head (sod-class-chain-head class)))
      (sequence-output (stream sequencer)
	:constraint ((*instance-class* :object chain-head :ichain :start)
		     (*instance-class* :object class :slots :start)
		     (*instance-class* :object class :slots)
		     (*instance-class* :object class :slots :end)
		     (*instance-class* :object chain-head :ichain :end))
	((*instance-class* :object class :slots :start)
	 (format stream "      { /* Class ~A */~%" class))
	((*instance-class* :object class :slots :end)
	 (format stream "      },~%"))))))

(defmethod hook-output ((vtptr vtable-pointer)
			(reason (eql 'class)) sequencer)
  "Define a vtable pointer in a class object."
  (with-slots ((class %class) chain-head chain-tail) vtptr
    (sequence-output (stream sequencer)
      :constraint ((*instance-class* :object chain-head :ichain :start)
		   (*instance-class* :object chain-head :vtable)
		   (*instance-class* :object chain-head :ichain :end))
      ((*instance-class* :object chain-head :vtable)
       (format stream "      /* ~17@A = */ &~A.~A,~%"
	       "_vt"
	       (vtable-name class chain-head)
	       (sod-class-nickname chain-tail))))))

(defgeneric output-class-initializer (slot instance stream)
  (:documentation
   "Define an individual slot in a class object.")
  (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
    "If this slot has an initializer function, then call it; otherwise try to
     find an initializer as usual."
    (let ((func (effective-slot-initializer-function slot))
	  (direct-slot (effective-slot-direct-slot slot)))
      (if func
	  (format stream "        /* ~15@A = */ ~A,~%"
		  (sod-slot-name direct-slot)
		  (funcall func instance))
	  (call-next-method))))
  (:method ((slot effective-slot) (instance sod-class) stream)
    "Initialize a class slot by looking up an applicable initializer."
    (let ((init (find-class-initializer slot instance))
	  (direct-slot (effective-slot-direct-slot slot)))
      (format stream "        /* ~15@A = */ ~A,~%"
	      (sod-slot-name direct-slot)
	      (sod-initializer-value init)))))

(defmethod hook-output ((slot sod-class-effective-slot)
			(reason (eql 'class)) sequencer)
  "Write any necessary preparatory definitions for a class slot with a
   computed initializer."
  (let ((instance *instance-class*)
	(func (effective-slot-prepare-function slot)))
    (when func
      (sequence-output (stream sequencer)
	((instance :object :prepare)
	 (funcall func instance stream)))))
  (call-next-method))

(defmethod hook-output ((slot effective-slot)
			(reason (eql 'class)) sequencer)
  "Define a slot in a class object."
  (with-slots ((class %class) (dslot slot)) slot
    (let ((instance *instance-class*)
	  (super (sod-slot-class dslot)))
      (sequence-output (stream sequencer)
	((instance :object super :slots)
	 (output-class-initializer slot instance stream))))))

;;;----- That's all, folks --------------------------------------------------