X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/bd60ce6d5f67dd0fa0d29a58c8de567a28568380..c2438e62e7c3cf1b7006522cef61e8c6f797600b:/src/class-output.lisp

diff --git a/src/class-output.lisp b/src/class-output.lisp
index d6ead49..eb5bc26 100644
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -125,16 +125,14 @@
 	 (dolist (entry (vtmsgs-entries vtmsgs))
 	   (let* ((type (method-entry-function-type entry))
 		  (args (c-function-arguments type))
-		  (method (method-entry-effective-method entry))
-		  (message (effective-method-message method))
 		  (in-names nil) (out-names nil) (varargsp nil) (me "me"))
 	     (do ((args args (cdr args)))
 		 ((endp args))
-	       (let* ((raw-name (argument-name (car args)))
+	       (let* ((raw-name (princ-to-string (argument-name (car args))))
 		      (name (if (find raw-name
 				      (list "_vt"
 					    (sod-class-nickname class)
-					    (sod-message-name message))
+					    (method-entry-slot-name entry))
 				      :test #'string=)
 				(format nil "sod__a_~A" raw-name)
 				raw-name)))
@@ -151,11 +149,11 @@
 	       (format stream "#if __STDC_VERSION__ >= 199901~%"))
 	     (format stream "#define ~A(~{~A~^, ~}) ~
 				   ~A->_vt->~A.~A(~{~A~^, ~})~%"
-		     (message-macro-name class message)
+		     (message-macro-name class entry)
 		     (nreverse in-names)
 		     me
 		     (sod-class-nickname class)
-		     (sod-message-name message)
+		     (method-entry-slot-name entry)
 		     (nreverse out-names))
 	     (when varargsp
 	       (format stream "#endif~%"))))
@@ -298,11 +296,23 @@
 			 struct ~A {~%"
 		 (vtable-struct-tag chain-tail chain-head)))
 	((class :vtable chain-head :end)
-	 (format stream "};~2%"))))
+	 (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 struct ~A ~2I~_~A__vtable_~A;~:>~%"
-	       (vtable-struct-tag chain-tail chain-head)
+       (format stream "~@<extern const union ~A ~2I~_~A__vtable_~A;~:>~%"
+	       (vtable-union-tag chain-tail chain-head)
 	       class (sod-class-nickname chain-head))))))
 
 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
@@ -348,7 +358,7 @@
     (sequence-output (stream sequencer)
       ((class :vtmsgs (sod-message-class message) :slots)
        (pprint-logical-block (stream nil :prefix "  " :suffix ";")
-	 (pprint-c-type pointer-type stream (sod-message-name message)))
+	 (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
        (terpri stream)))))
 
 (defmethod hook-output progn ((cptr class-pointer)
@@ -472,12 +482,12 @@ const struct ~A ~A__classobj = {~%"
 		   (class :vtables :end))
       ((class :vtable chain-head :start)
        (format stream "/* Vtable for ~A chain. */~@
-		       const struct ~A ~A = {~%"
+		       const union ~A ~A = { {~%"
 	       chain-head
-	       (vtable-struct-tag chain-tail chain-head)
+	       (vtable-union-tag chain-tail chain-head)
 	       (vtable-name class chain-head)))
       ((class :vtable chain-head :end)
-       (format stream "};~2%")))))
+       (format stream "} };~2%")))))
 
 (defmethod hook-output progn ((cptr class-pointer)
 			      (reason (eql :c))
@@ -541,15 +551,15 @@ const struct ~A ~A__classobj = {~%"
 (defmethod hook-output progn ((entry method-entry)
 			      (reason (eql :c))
 			      sequencer)
-  (with-slots (method chain-head chain-tail) entry
+  (with-slots (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,~%"
-		 (sod-message-name message)
-		 (method-entry-function-name method chain-head)))))))
+		 (method-entry-slot-name entry)
+		 (method-entry-function-name method chain-head role)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Filling in the class object.
@@ -594,8 +604,10 @@ const struct ~A ~A__classobj = {~%"
 		   (*instance-class* :object chain-head :vtable)
 		   (*instance-class* :object chain-head :ichain :end))
       ((*instance-class* :object chain-head :vtable)
-       (format stream "      &~A__vtable_~A,~%"
-	       class (sod-class-nickname chain-head))))))
+       (format stream "      /* ~17@A = */ &~A.~A,~%"
+	       "_vt"
+	       (vtable-name class chain-head)
+	       (sod-class-nickname chain-tail))))))
 
 (defgeneric find-class-initializer (slot class)
   (:method ((slot effective-slot) (class sod-class))