[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)
  (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)
  (with-slots (ichains) ilayout
    (dolist (ichain ichains) (hook-output ichain reason sequencer))))

(defmethod hook-output :after ((ichain ichain) reason sequencer)
  (dolist (item (ichain-body ichain)) (hook-output item reason sequencer)))

(defmethod hook-output :after ((islots islots) reason sequencer)
  (dolist (slot (islots-slots islots)) (hook-output slot reason sequencer)))

(defmethod hook-output :after ((vtable vtable) reason sequencer)
  (with-slots (body) vtable
    (dolist (item body) (hook-output item reason sequencer))))

(defmethod hook-output :after ((vtmsgs vtmsgs) reason sequencer)
  (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)

  ;; 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)

  ;; 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)
  (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)
  (with-slots ((class %class)) 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)
  (dolist (ichain (ilayout-ichains ilayout))
    (hook-output ichain 'ilayout sequencer)))

(defmethod hook-output ((ichain ichain) (reason (eql :h)) sequencer)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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 *instance-class* nil
  "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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (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)
  (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
    (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)
    (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)
  (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)
  (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 --------------------------------------------------