It lives!

[sod] / class-output.lisp

diff --git a/class-output.lisp b/class-output.lisp
index ee2daf3f9ddab23b933e8270f160615e9f43b011..da6531b12e4f7dde38b052ea9ae14a829b0d1a6c 100644 (file)
--- a/class-output.lisp
+++ b/class-output.lisp
@@ -93,8 +93,8 @@ (defmethod add-output-hooks progn
     ((class :object)
      (let ((metaclass (sod-class-metaclass class))
           (metaroot (find-root-metaclass class)))
     ((class :object)
      (let ((metaclass (sod-class-metaclass class))
           (metaroot (find-root-metaclass class)))

-       (format stream "/* The class object. */~%~
-                      extern const struct ~A ~A__classobj;~%~
+       (format stream "/* The class object. */~@
+                      extern const struct ~A ~A__classobj;~@

                       #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
               (ilayout-struct-tag metaclass) class
               (sod-class-nickname (sod-class-chain-head metaroot))
                       #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
               (ilayout-struct-tag metaclass) class
               (sod-class-nickname (sod-class-chain-head metaroot))


@@ -106,7 +106,7 @@ (defmethod add-output-hooks progn
       (add-output-hooks slot 'populate-islots sequencer))
     (sequence-output (stream sequencer)
       ((class :islots :start)
       (add-output-hooks slot 'populate-islots sequencer))
     (sequence-output (stream sequencer)
       ((class :islots :start)

-       (format stream "/* Instance slots. */~%~
+       (format stream "/* Instance slots. */~@

                       struct ~A {~%"
               (islots-struct-tag class)))
       ((class :islots :end)
                       struct ~A {~%"
               (islots-struct-tag class)))
       ((class :islots :end)


@@ -141,9 +141,11 @@ (defmethod add-output-hooks progn
                    sequencer))
 
 (defmethod add-output-hooks progn ((class sod-class) reason sequencer)
                    sequencer))
 
 (defmethod add-output-hooks progn ((class sod-class) reason sequencer)

-  (with-slots (ilayout vtables methods) class
+  (with-slots (ilayout vtables methods effective-methods) class

     (add-output-hooks ilayout reason sequencer)
     (dolist (method methods) (add-output-hooks method reason sequencer))
     (add-output-hooks ilayout reason sequencer)
     (dolist (method methods) (add-output-hooks method reason sequencer))

+    (dolist (method effective-methods)
+      (add-output-hooks method reason sequencer))

     (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
 
 ;;;--------------------------------------------------------------------------
     (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
 
 ;;;--------------------------------------------------------------------------


@@ -166,7 +168,7 @@ (defmethod add-output-hooks progn
   (with-slots (class ichains) ilayout
     (sequence-output (stream sequencer)
       ((class :ilayout :start)
   (with-slots (class ichains) ilayout
     (sequence-output (stream sequencer)
       ((class :ilayout :start)

-       (format stream "/* Instance layout. */~%~
+       (format stream "/* Instance layout. */~@

                       struct ~A {~%"
               (ilayout-struct-tag class)))
       ((class :ilayout :end)
                       struct ~A {~%"
               (ilayout-struct-tag class)))
       ((class :ilayout :end)


@@ -185,13 +187,13 @@ (defmethod add-output-hooks progn
                     (class :ichain chain-head :end)
                     (class :ichains :end))
        ((class :ichain chain-head :start)
                     (class :ichain chain-head :end)
                     (class :ichains :end))
        ((class :ichain chain-head :start)

-        (format stream "/* Instance chain structure. */~%~
+        (format stream "/* Instance chain structure. */~@

                         struct ~A {~%"
                 (ichain-struct-tag chain-tail chain-head)))
        ((class :ichain chain-head :end)
         (format stream "};~2%")
                         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 {~%~
+        (format stream "/* Union of equivalent superclass chains. */~@
+                        union ~A {~@

                         ~:{  struct ~A ~A;~%~}~
                         };~2%"
                 (ichain-union-tag chain-tail chain-head)
                         ~:{  struct ~A ~A;~%~}~
                         };~2%"
                 (ichain-union-tag chain-tail chain-head)


@@ -259,7 +261,7 @@ (defmethod add-output-hooks progn
                     (class :vtable chain-head :end)
                     (class :vtables :end))
        ((class :vtable chain-head :start)
                     (class :vtable chain-head :end)
                     (class :vtables :end))
        ((class :vtable chain-head :start)

-        (format stream "/* Vtable structure. */~%~
+        (format stream "/* Vtable structure. */~@

                         struct ~A {~%"
                 (vtable-struct-tag chain-tail chain-head)))
        ((class :vtable chain-head :end)
                         struct ~A {~%"
                 (vtable-struct-tag chain-tail chain-head)))
        ((class :vtable chain-head :end)


@@ -290,7 +292,7 @@ (defmethod add-output-hooks progn
                     (subclass :vtmsgs class :end)
                     (subclass :vtmsgs :end))
        ((subclass :vtmsgs class :start)
                     (subclass :vtmsgs class :end)
                     (subclass :vtmsgs :end))
        ((subclass :vtmsgs class :start)

-        (format stream "/* Messages protocol from class ~A */~%~
+        (format stream "/* Messages protocol from class ~A */~@

                         struct ~A {~%"
                 class
                 (vtmsgs-struct-tag subclass class)))
                         struct ~A {~%"
                 class
                 (vtmsgs-struct-tag subclass class)))


@@ -357,7 +359,7 @@ (defmethod add-output-hooks progn
     ((:classes :start)
      (class :banner)
      (class :direct-methods :start) (class :direct-methods :end)
     ((:classes :start)
      (class :banner)
      (class :direct-methods :start) (class :direct-methods :end)

-     (class :effective-methods :start) (class :effective-methods :end)
+     (class :effective-methods)

      (class :vtables :start) (class :vtables :end)
      (class :object :prepare) (class :object :start) (class :object :end)
      (:classes :end))
      (class :vtables :start) (class :vtables :end)
      (class :object :prepare) (class :object :start) (class :object :end)
      (:classes :end))


@@ -382,9 +384,6 @@ (defmethod add-output-hooks progn
 ;;;--------------------------------------------------------------------------
 ;;; Direct methods.
 
 ;;;--------------------------------------------------------------------------
 ;;; Direct methods.
 

-;; This could well want splitting out into some more elaborate protocol.  We
-;; need a bunch of refactoring anyway.
-

 (defmethod add-output-hooks progn
     ((method delegating-direct-method) (reason (eql :c)) sequencer)
   (with-slots (class body) method
 (defmethod add-output-hooks progn
     ((method delegating-direct-method) (reason (eql :c)) sequencer)
   (with-slots (class body) method


@@ -420,6 +419,90 @@ (defmethod add-output-hooks progn
       ((class :direct-method method :end)
        (terpri stream)))))
 
       ((class :direct-method method :end)
        (terpri stream)))))
 

+;;;--------------------------------------------------------------------------
+;;; Vtables.
+
+(defmethod add-output-hooks progn
+    ((vtable vtable) (reason (eql :c)) sequencer)
+  (with-slots (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. */~@
+                      static const struct ~A ~A = {~%"
+              chain-head
+              (vtable-struct-tag chain-tail chain-head)
+              (vtable-name chain-tail chain-head)))
+      ((class :vtable chain-head :end)
+       (format stream "};~2%")))))
+
+(defmethod add-output-hooks 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)
+       (format stream "  &~A__classobj.~A.~A,~%"
+              (sod-class-metaclass class)
+              (sod-class-nickname meta-chain-head)
+              (sod-class-nickname metaclass))))))
+
+(defmethod add-output-hooks 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)
+       (format stream "  offsetof(struct ~A, ~A),~%"
+              (ilayout-struct-tag class)
+              (sod-class-nickname chain-head))))))
+
+(defmethod add-output-hooks 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)
+       (format stream "  SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
+              (ilayout-struct-tag class)
+              (sod-class-nickname chain-head)
+              (sod-class-nickname target-head))))))
+
+(defmethod add-output-hooks progn
+    ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
+  (with-slots (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 add-output-hooks 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)
+        (format stream "    ~A,~%"
+                (method-entry-function-name method chain-head)))))))
+

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