An actual running implementation, which makes code that compiles.

[sod] / src / class-output.lisp

diff --git a/src/class-output.lisp b/src/class-output.lisp
index b168d89..53812c9 100644 (file)
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -110,11 +110,9 @@
                    sequencer))
 
 (defmethod hook-output progn ((class sod-class) reason sequencer)
-  (with-slots (ilayout vtables methods effective-methods) class
+  (with-slots (ilayout vtables 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))))
 
 ;;;--------------------------------------------------------------------------
@@ -245,7 +243,7 @@
         (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))))))
 
@@ -290,12 +288,13 @@
   (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 ";")
-        (pprint-c-type commented-type stream (sod-message-name message)))
+        (pprint-c-type pointer-type stream (sod-message-name message)))
        (terpri stream)))))
 
 (defmethod hook-output progn ((cptr class-pointer)
@@ -306,9 +305,8 @@
       ((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)
   (with-slots (class chain-head) boff
@@ -360,7 +358,7 @@ const struct ~A ~A__classobj = {~%"
                      sequencer)))
 
 ;;;--------------------------------------------------------------------------
-;;; Direct methods.
+;;; Direct and effective methods.
 
 (defmethod hook-output progn ((method delegating-direct-method)
                              (reason (eql :c))
@@ -420,10 +418,10 @@ const struct ~A ~A__classobj = {~%"
                   (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)
-              (vtable-name chain-tail chain-head)))
+              (vtable-name class chain-head)))
       ((class :vtable chain-head :end)
        (format stream "};~2%")))))
 
@@ -436,7 +434,11 @@ const struct ~A ~A__classobj = {~%"
                   (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,~%"
+       (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")
               (sod-class-metaclass class)
               (sod-class-nickname meta-chain-head)
               (sod-class-nickname metaclass))))))
@@ -448,7 +450,8 @@ const struct ~A ~A__classobj = {~%"
                   (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))))))
 
@@ -461,7 +464,8 @@ const struct ~A ~A__classobj = {~%"
                   (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))))))
@@ -489,7 +493,8 @@ const struct ~A ~A__classobj = {~%"
           (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)))))))
 
 ;;;--------------------------------------------------------------------------
@@ -549,17 +554,23 @@ const struct ~A ~A__classobj = {~%"
 
 (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
-         (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)
-    (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)
-       (:simple (format stream "        ~A,~%"
+       (:simple (format stream "        /* ~15@A = */ ~A,~%"
+                        (sod-slot-name direct-slot)
                         (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))