src/class-output.lisp: Insert the correct class pointers.

[sod] / src / class-output.lisp

diff --git a/src/class-output.lisp b/src/class-output.lisp
index 58d483048d79ca4a8b5abc77c645ceb19194ba92..687b22c91af7e30b22ae60ea915e80e2f1dca164 100644 (file)
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -28,8 +28,7 @@ (cl:in-package #:sod)
 ;;;--------------------------------------------------------------------------
 ;;; Classes.
 
 ;;;--------------------------------------------------------------------------
 ;;; Classes.
 

-(defmethod hook-output progn ((class sod-class) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer)

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


@@ -114,15 +113,15 @@ (defmethod hook-output progn ((class sod-class) reason sequencer)
   (with-slots (ilayout vtables methods effective-methods) class
     (hook-output ilayout reason sequencer)
     (dolist (method methods) (hook-output method reason sequencer))
   (with-slots (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 (method effective-methods) (hook-output method reason sequencer))

     (dolist (vtable vtables) (hook-output vtable reason sequencer))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Instance structure.
 
     (dolist (vtable vtables) (hook-output vtable reason sequencer))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Instance structure.
 

-(defmethod hook-output progn ((slot sod-slot) (reason (eql 'islots))
-                                  sequencer)
+(defmethod hook-output progn ((slot sod-slot)
+                             (reason (eql 'islots))
+                             sequencer)

   (sequence-output (stream sequencer)
     (((sod-slot-class slot) :islots :slots)
      (pprint-logical-block (stream nil :prefix "  " :suffix ";")
   (sequence-output (stream sequencer)
     (((sod-slot-class slot) :islots :slots)
      (pprint-logical-block (stream nil :prefix "  " :suffix ";")


@@ -137,8 +136,7 @@ (defmethod hook-output progn ((ichain ichain) reason sequencer)
   (dolist (item (ichain-body ichain))
     (hook-output item reason sequencer)))
 
   (dolist (item (ichain-body ichain))
     (hook-output item reason sequencer)))
 

-(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer)

   (with-slots (class ichains) ilayout
     (sequence-output (stream sequencer)
       ((class :ilayout :start)
   (with-slots (class ichains) ilayout
     (sequence-output (stream sequencer)
       ((class :ilayout :start)


@@ -150,8 +148,7 @@ (defmethod hook-output progn ((ilayout ilayout) (reason (eql :h))
     (dolist (ichain ichains)
       (hook-output ichain 'ilayout sequencer))))
 
     (dolist (ichain ichains)
       (hook-output ichain 'ilayout sequencer))))
 

-(defmethod hook-output progn ((ichain ichain) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer)

   (with-slots (class chain-head chain-tail) ichain
     (when (eq class chain-tail)
       (sequence-output (stream sequencer)
   (with-slots (class chain-head chain-tail) ichain
     (when (eq class chain-tail)
       (sequence-output (stream sequencer)


@@ -180,8 +177,9 @@ (defmethod hook-output progn ((ichain ichain) (reason (eql :h))
                                 (sod-class-nickname super)))
                         (sod-class-chain chain-tail))))))))
 
                                 (sod-class-nickname super)))
                         (sod-class-chain chain-tail))))))))
 

-(defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout))
-                                  sequencer)
+(defmethod hook-output progn ((ichain ichain)
+                             (reason (eql 'ilayout))
+                             sequencer)

   (with-slots (class chain-head chain-tail) ichain
     (sequence-output (stream sequencer)
       ((class :ilayout :slots)
   (with-slots (class chain-head chain-tail) ichain
     (sequence-output (stream sequencer)
       ((class :ilayout :slots)


@@ -189,8 +187,9 @@ (defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout))
               (ichain-union-tag chain-tail chain-head)
               (sod-class-nickname chain-head))))))
 
               (ichain-union-tag chain-tail chain-head)
               (sod-class-nickname chain-head))))))
 

-(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((vtptr vtable-pointer)
+                             (reason (eql :h))
+                             sequencer)

   (with-slots (class chain-head chain-tail) vtptr
     (sequence-output (stream sequencer)
       ((class :ichain chain-head :slots)
   (with-slots (class chain-head chain-tail) vtptr
     (sequence-output (stream sequencer)
       ((class :ichain chain-head :slots)


@@ -201,8 +200,7 @@ (defmethod hook-output progn ((islots islots) reason sequencer)
   (dolist (slot (islots-slots islots))
     (hook-output slot reason sequencer)))
 
   (dolist (slot (islots-slots islots))
     (hook-output slot reason sequencer)))
 

-(defmethod hook-output progn ((islots islots) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer)

   (with-slots (class subclass slots) islots
     (sequence-output (stream sequencer)
       ((subclass :ichain (sod-class-chain-head class) :slots)
   (with-slots (class subclass slots) islots
     (sequence-output (stream sequencer)
       ((subclass :ichain (sod-class-chain-head class) :slots)


@@ -217,8 +215,9 @@ (defmethod hook-output progn ((vtable vtable) reason sequencer)
   (with-slots (body) vtable
     (dolist (item body) (hook-output item reason sequencer))))
 
   (with-slots (body) vtable
     (dolist (item body) (hook-output item reason sequencer))))
 

-(defmethod hook-output progn ((method sod-method) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((method sod-method)
+                             (reason (eql :h))
+                             sequencer)

   (with-slots (class) method
     (sequence-output (stream sequencer)
       ((class :methods)
   (with-slots (class) method
     (sequence-output (stream sequencer)
       ((class :methods)


@@ -228,8 +227,7 @@ (defmethod hook-output progn ((method sod-method) (reason (eql :h))
                        (sod-method-function-name method))
         (format stream ";~%"))))))
 
                        (sod-method-function-name method))
         (format stream ";~%"))))))
 

-(defmethod hook-output progn ((vtable vtable) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer)

   (with-slots (class chain-head chain-tail) vtable
     (when (eq class chain-tail)
       (sequence-output (stream sequencer)
   (with-slots (class chain-head chain-tail) vtable
     (when (eq class chain-tail)
       (sequence-output (stream sequencer)


@@ -246,12 +244,11 @@ (defmethod hook-output progn ((vtable vtable) (reason (eql :h))
         (format stream "};~2%"))))
     (sequence-output (stream sequencer)
       ((class :vtable-externs)
         (format stream "};~2%"))))
     (sequence-output (stream sequencer)
       ((class :vtable-externs)

-       (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
+       (format stream "~@<extern const struct ~A ~2I~_~A__vtable_~A;~:>~%"

               (vtable-struct-tag chain-tail chain-head)
               class (sod-class-nickname chain-head))))))
 
               (vtable-struct-tag chain-tail chain-head)
               class (sod-class-nickname chain-head))))))
 

-(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)

   (with-slots (class subclass chain-head chain-tail) vtmsgs
     (sequence-output (stream sequencer)
       ((subclass :vtable chain-head :slots)
   (with-slots (class subclass chain-head chain-tail) vtmsgs
     (sequence-output (stream sequencer)
       ((subclass :vtable chain-head :slots)


@@ -259,8 +256,9 @@ (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h))
               (vtmsgs-struct-tag subclass class)
               (sod-class-nickname class))))))
 
               (vtmsgs-struct-tag subclass class)
               (sod-class-nickname class))))))
 

-(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql 'vtmsgs))
-                                  sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs)
+                             (reason (eql 'vtmsgs))
+                             sequencer)

   (when (vtmsgs-entries vtmsgs)
     (with-slots (class subclass) vtmsgs
       (sequence-output (stream sequencer)
   (when (vtmsgs-entries vtmsgs)
     (with-slots (class subclass) vtmsgs
       (sequence-output (stream sequencer)


@@ -281,43 +279,41 @@ (defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
   (with-slots (entries) vtmsgs
     (dolist (entry entries) (hook-output entry reason sequencer))))
 
   (with-slots (entries) vtmsgs
     (dolist (entry entries) (hook-output entry reason sequencer))))
 

-(defmethod hook-output progn ((entry method-entry) reason sequencer)
-  (with-slots (method) entry
-    (hook-output method reason sequencer)))
-
-(defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs))
-                                  sequencer)
+(defmethod hook-output progn ((entry method-entry)
+                             (reason (eql 'vtmsgs))
+                             sequencer)

   (let* ((method (method-entry-effective-method entry))
         (message (effective-method-message method))
         (class (effective-method-class method))
   (let* ((method (method-entry-effective-method entry))
         (message (effective-method-message method))
         (class (effective-method-class method))

-        (type (method-entry-function-type entry))
-        (commented-type (commentify-function-type type)))
+        (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 ";")
     (sequence-output (stream sequencer)
       ((class :vtmsgs (sod-message-class message) :slots)
        (pprint-logical-block (stream nil :prefix "  " :suffix ";")

-        (pprint-c-type commented-type stream (sod-message-name message)))
+        (pprint-c-type pointer-type stream (sod-message-name message)))

        (terpri stream)))))
 
        (terpri stream)))))
 

-(defmethod hook-output progn ((cptr class-pointer) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((cptr class-pointer)
+                             (reason (eql :h))
+                             sequencer)

   (with-slots (class chain-head metaclass meta-chain-head) cptr
     (sequence-output (stream sequencer)
       ((class :vtable chain-head :slots)
        (format stream "  const ~A *~:[_class~;~:*_cls_~A~];~%"
               metaclass
   (with-slots (class chain-head metaclass meta-chain-head) cptr
     (sequence-output (stream sequencer)
       ((class :vtable chain-head :slots)
        (format stream "  const ~A *~:[_class~;~:*_cls_~A~];~%"
               metaclass

-              (if (sod-class-direct-superclasses meta-chain-head)
-                  (sod-class-nickname meta-chain-head)
-                  nil))))))
+              (and (sod-class-direct-superclasses meta-chain-head)
+                   (sod-class-nickname meta-chain-head)))))))

 
 

-(defmethod hook-output progn ((boff base-offset) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer)

   (with-slots (class chain-head) boff
     (sequence-output (stream sequencer)
       ((class :vtable chain-head :slots)
        (write-line "  size_t _base;" stream)))))
 
   (with-slots (class chain-head) boff
     (sequence-output (stream sequencer)
       ((class :vtable chain-head :slots)
        (write-line "  size_t _base;" stream)))))
 

-(defmethod hook-output progn ((choff chain-offset) (reason (eql :h))
-                                  sequencer)
+(defmethod hook-output progn ((choff chain-offset)
+                             (reason (eql :h))
+                             sequencer)

   (with-slots (class chain-head target-head) choff
     (sequence-output (stream sequencer)
       ((class :vtable chain-head :slots)
   (with-slots (class chain-head target-head) choff
     (sequence-output (stream sequencer)
       ((class :vtable chain-head :slots)


@@ -329,8 +325,7 @@ (defmethod hook-output progn ((choff chain-offset) (reason (eql :h))
 
 (defvar *instance-class*)
 
 
 (defvar *instance-class*)
 

-(defmethod hook-output progn ((class sod-class) (reason (eql :c))
-                                  sequencer)
+(defmethod hook-output progn ((class sod-class) (reason (eql :c)) sequencer)

   (sequence-output (stream sequencer)
 
     :constraint
   (sequence-output (stream sequencer)
 
     :constraint


@@ -360,10 +355,11 @@ (defmethod hook-output progn ((class sod-class) (reason (eql :c))
                      sequencer)))
 
 ;;;--------------------------------------------------------------------------
                      sequencer)))
 
 ;;;--------------------------------------------------------------------------

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

 
 

-(defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c))
-                                  sequencer)
+(defmethod hook-output progn ((method delegating-direct-method)
+                             (reason (eql :c))
+                             sequencer)

   (with-slots (class body) method
     (unless body
       (return-from hook-output))
   (with-slots (class body) method
     (unless body
       (return-from hook-output))


@@ -376,8 +372,9 @@ (defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c)
       ((class :direct-method method :end)
        (format stream "#undef CALL_NEXT_METHOD~%")))))
 
       ((class :direct-method method :end)
        (format stream "#undef CALL_NEXT_METHOD~%")))))
 

-(defmethod hook-output progn ((method sod-method) (reason (eql :c))
-                                  sequencer)
+(defmethod hook-output progn ((method sod-method)
+                             (reason (eql :c))
+                             sequencer)

   (with-slots (class body) method
     (unless body
       (return-from hook-output))
   (with-slots (class body) method
     (unless body
       (return-from hook-output))


@@ -397,7 +394,8 @@ (defmethod hook-output progn ((method sod-method) (reason (eql :c))
       ((class :direct-method method :end)
        (terpri stream)))))
 
       ((class :direct-method method :end)
        (terpri stream)))))
 

-(defmethod hook-output progn ((method basic-effective-method) (reason (eql :c))
+(defmethod hook-output progn ((method basic-effective-method)
+                             (reason (eql :c))

                              sequencer)
   (with-slots (class functions) method
     (sequence-output (stream sequencer)
                              sequencer)
   (with-slots (class functions) method
     (sequence-output (stream sequencer)


@@ -408,8 +406,7 @@ (defmethod hook-output progn ((method basic-effective-method) (reason (eql :c))
 ;;;--------------------------------------------------------------------------
 ;;; Vtables.
 
 ;;;--------------------------------------------------------------------------
 ;;; Vtables.
 

-(defmethod hook-output progn ((vtable vtable) (reason (eql :c))
-                                  sequencer)
+(defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer)

   (with-slots (class chain-head chain-tail) vtable
     (sequence-output (stream sequencer)
       :constraint ((class :vtables :start)
   (with-slots (class chain-head chain-tail) vtable
     (sequence-output (stream sequencer)
       :constraint ((class :vtables :start)


@@ -418,53 +415,59 @@ (defmethod hook-output progn ((vtable vtable) (reason (eql :c))
                   (class :vtables :end))
       ((class :vtable chain-head :start)
        (format stream "/* Vtable for ~A chain. */~@
                   (class :vtables :end))
       ((class :vtable chain-head :start)
        (format stream "/* Vtable for ~A chain. */~@

-                      static const struct ~A ~A = {~%"
+                      const struct ~A ~A = {~%"

               chain-head
               (vtable-struct-tag chain-tail chain-head)
               chain-head
               (vtable-struct-tag chain-tail chain-head)

-              (vtable-name chain-tail chain-head)))
+              (vtable-name class chain-head)))

       ((class :vtable chain-head :end)
        (format stream "};~2%")))))
 
       ((class :vtable chain-head :end)
        (format stream "};~2%")))))
 

-(defmethod hook-output progn ((cptr class-pointer) (reason (eql :c))
-                                  sequencer)
+(defmethod hook-output progn ((cptr class-pointer)
+                             (reason (eql :c))
+                             sequencer)

   (with-slots (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)
   (with-slots (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 "  &~A__classobj.~A.~A,~%"
-              (sod-class-metaclass class)
+       (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))))))
 
               (sod-class-nickname meta-chain-head)
               (sod-class-nickname metaclass))))))
 

-(defmethod hook-output progn ((boff base-offset) (reason (eql :c))
-                                  sequencer)
+(defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer)

   (with-slots (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)
   (with-slots (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 "  offsetof(struct ~A, ~A),~%"
+       (format stream "  /* ~21@A = */ offsetof(struct ~A, ~A),~%"
+              "_base"

               (ilayout-struct-tag class)
               (sod-class-nickname chain-head))))))
 
               (ilayout-struct-tag class)
               (sod-class-nickname chain-head))))))
 

-(defmethod hook-output progn ((choff chain-offset) (reason (eql :c))
-                                  sequencer)
+(defmethod hook-output progn ((choff chain-offset)
+                             (reason (eql :c))
+                             sequencer)

   (with-slots (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)
   (with-slots (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 "  SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
+       (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))))))
 
               (ilayout-struct-tag class)
               (sod-class-nickname chain-head)
               (sod-class-nickname target-head))))))
 

-(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c))
-                                  sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)

   (with-slots (class subclass chain-head) vtmsgs
     (sequence-output (stream sequencer)
       :constraint ((subclass :vtable chain-head :start)
   (with-slots (class subclass chain-head) vtmsgs
     (sequence-output (stream sequencer)
       :constraint ((subclass :vtable chain-head :start)


@@ -478,22 +481,25 @@ (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c))
       ((subclass :vtable chain-head :vtmsgs class :end)
        (format stream "  },~%")))))
 
       ((subclass :vtable chain-head :vtmsgs class :end)
        (format stream "  },~%")))))
 

-(defmethod hook-output progn ((entry method-entry) (reason (eql :c))
-                                  sequencer)
+(defmethod hook-output progn ((entry method-entry)
+                             (reason (eql :c))
+                             sequencer)

   (with-slots (method chain-head chain-tail) 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)
   (with-slots (method chain-head chain-tail) 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 "    ~A,~%"
+        (format stream "    /* ~19@A = */ ~A,~%"
+                (sod-message-name message)

                 (method-entry-function-name method chain-head)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Filling in the class object.
 
                 (method-entry-function-name method chain-head)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Filling in the class object.
 

-(defmethod hook-output progn ((ichain ichain) (reason (eql 'class))
-                                  sequencer)
+(defmethod hook-output progn ((ichain ichain)
+                             (reason (eql 'class))
+                             sequencer)

   (with-slots (class chain-head) ichain
     (sequence-output (stream sequencer)
       :constraint ((*instance-class* :object :start)
   (with-slots (class chain-head) ichain
     (sequence-output (stream sequencer)
       :constraint ((*instance-class* :object :start)


@@ -506,8 +512,9 @@ (defmethod hook-output progn ((ichain ichain) (reason (eql 'class))
       ((*instance-class* :object chain-head :ichain :end)
        (format stream "  } },~%")))))
 
       ((*instance-class* :object chain-head :ichain :end)
        (format stream "  } },~%")))))
 

-(defmethod hook-output progn ((islots islots) (reason (eql 'class))
-                                  sequencer)
+(defmethod hook-output progn ((islots islots)
+                             (reason (eql 'class))
+                             sequencer)

   (with-slots (class) islots
     (let ((chain-head (sod-class-chain-head class)))
       (sequence-output (stream sequencer)
   (with-slots (class) islots
     (let ((chain-head (sod-class-chain-head class)))
       (sequence-output (stream sequencer)


@@ -521,8 +528,9 @@ (defmethod hook-output progn ((islots islots) (reason (eql 'class))
        ((*instance-class* :object class :slots :end)
         (format stream "      },~%"))))))
 
        ((*instance-class* :object class :slots :end)
         (format stream "      },~%"))))))
 

-(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class))
-                                  sequencer)
+(defmethod hook-output progn ((vtptr vtable-pointer)
+                             (reason (eql 'class))
+                             sequencer)

   (with-slots (class chain-head chain-tail) vtptr
     (sequence-output (stream sequencer)
       :constraint ((*instance-class* :object chain-head :ichain :start)
   (with-slots (class chain-head chain-tail) vtptr
     (sequence-output (stream sequencer)
       :constraint ((*instance-class* :object chain-head :ichain :start)


@@ -543,20 +551,27 @@ (defgeneric find-class-initializer (slot class)
 
 (defgeneric output-class-initializer (slot instance stream)
   (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
 
 (defgeneric output-class-initializer (slot instance stream)
   (:method ((slot sod-class-effective-slot) (instance sod-class) stream)

-    (let ((func (effective-slot-initializer-function slot)))
+    (let ((func (effective-slot-initializer-function slot))
+         (direct-slot (effective-slot-direct-slot slot)))

       (if func
       (if func

-         (format stream "        ~A,~%" (funcall func instance))
+         (format stream "        /* ~15@A = */ ~A,~%"
+                 (sod-slot-name direct-slot)
+                 (funcall func instance))

          (call-next-method))))
   (:method ((slot effective-slot) (instance sod-class) stream)
          (call-next-method))))
   (:method ((slot effective-slot) (instance sod-class) stream)

-    (let ((init (find-class-initializer slot instance)))
+    (let ((init (find-class-initializer slot instance))
+         (direct-slot (effective-slot-direct-slot slot)))

       (ecase (sod-initializer-value-kind init)
       (ecase (sod-initializer-value-kind init)

-       (:simple (format stream "        ~A,~%"
+       (:simple (format stream "        /* ~15@A = */ ~A,~%"
+                        (sod-slot-name direct-slot)

                         (sod-initializer-value-form init)))
                         (sod-initializer-value-form init)))

-       (:compound (format stream "        ~@<{ ~;~A~; },~:>~%"
-                        (sod-initializer-value-form init)))))))
+       (:compound (format stream "        /* ~15@A = */ ~@<{ ~;~A~; },~:>~%"
+                          (sod-slot-name direct-slot)
+                          (sod-initializer-value-form init)))))))

 
 

-(defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class))
-                                  sequencer)
+(defmethod hook-output progn ((slot sod-class-effective-slot)
+                             (reason (eql 'class))
+                             sequencer)

   (let ((instance *instance-class*)
        (func (effective-slot-prepare-function slot)))
     (when func
   (let ((instance *instance-class*)
        (func (effective-slot-prepare-function slot)))
     (when func


@@ -564,8 +579,9 @@ (defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'clas
        ((instance :object :prepare)
         (funcall func instance stream))))))
 
        ((instance :object :prepare)
         (funcall func instance stream))))))
 

-(defmethod hook-output progn ((slot effective-slot) (reason (eql 'class))
-                                  sequencer)
+(defmethod hook-output progn ((slot effective-slot)
+                             (reason (eql 'class))
+                             sequencer)

   (with-slots (class (dslot slot)) slot
     (let ((instance *instance-class*)
          (super (sod-slot-class dslot)))
   (with-slots (class (dslot slot)) slot
     (let ((instance *instance-class*)
          (super (sod-slot-class dslot)))