X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/d9c15186bf79bcac3caf752dd0936233778aa8f2..ddee4bb174ad62e6a9d7ecb49d69867fb2b4742c:/class-layout.lisp

diff --git a/class-layout.lisp b/class-layout.lisp
index df068ed..a37852e 100644
--- a/class-layout.lisp
+++ b/class-layout.lisp
@@ -99,7 +99,9 @@
 (defclass vtable-pointer ()
   ((class :initarg :class :type sod-class :reader vtable-pointer-class)
    (chain-head :initarg :chain-head :type sod-class
-	       :reader vtable-pointer-chain-head))
+	       :reader vtable-pointer-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+	       :reader vtable-pointer-chain-tail))
   (:documentation
    "A pointer to the vtable for CLASS corresponding to a particular CHAIN."))
 
@@ -114,6 +116,7 @@
 (defclass ichain ()
   ((class :initarg :class :type sod-class :reader ichain-class)
    (chain-head :initarg :chain-head :type sod-class :reader ichain-head)
+   (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)
    (body :initarg :body :type list :reader ichain-body))
   (:documentation
    "All of the instance layout for CLASS corresponding to a particular CHAIN.
@@ -167,17 +170,21 @@
 				(sod-class-slots class))))
 
 (defmethod compute-ichain ((class sod-class) chain)
-  (let* ((head (car chain))
+  (let* ((chain-head (car chain))
+	 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+			   :key #'sod-class-chain-head))
 	 (vtable-pointer (make-instance 'vtable-pointer
 					:class class
-					:chain-head head))
+					:chain-head chain-head
+					:chain-tail chain-tail))
 	 (islots (remove-if-not #'islots-slots
 				(mapcar (lambda (super)
 					  (compute-islots super class))
 					chain))))
     (make-instance 'ichain
 		   :class class
-		   :chain-head head
+		   :chain-head chain-head
+		   :chain-tail chain-tail
 		   :body (cons vtable-pointer islots))))
 
 (defmethod compute-ilayout ((class sod-class))
@@ -245,9 +252,10 @@
 (defclass method-entry ()
   ((method :initarg :method :type effective-method
 	   :reader method-entry-effective-method)
-   (chain-head :initarg :chain-head
-	       :type sod-class
-	       :reader method-entry-chain-head))
+   (chain-head :initarg :chain-head :type sod-class
+	       :reader method-entry-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+	       :reader method-entry-chain-tail))
   (:documentation
    "An entry point into an effective method.
 
@@ -265,7 +273,7 @@
 	    (method-entry-effective-method entry)
 	    (sod-class-nickname (method-entry-chain-head entry)))))
 
-(defgeneric make-method-entry (effective-method chain-head)
+(defgeneric make-method-entry (effective-method chain-head chain-tail)
   (:documentation
    "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
 
@@ -280,12 +288,14 @@
    (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
    (chain-head :initarg :chain-head :type sod-class
 	       :reader vtmsgs-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+	       :reader vtmsgs-chain-tail)
    (entries :initarg :entries :type list :reader vtmsgs-entries))
   (:documentation
    "The message dispatch table for a particular CLASS.
 
-   The BODY contains a list of effective method objects for the messages
-   defined on CLASS, customized for calling from the chain headed by
+   The BODY contains a list of effective method entry objects for the
+   messages defined on CLASS, customized for calling from the chain headed by
    CHAIN-HEAD."))
 
 (defmethod print-object ((vtmsgs vtmsgs) stream)
@@ -295,7 +305,7 @@
 	    (vtmsgs-class vtmsgs)
 	    (vtmsgs-entries vtmsgs))))
 
-(defgeneric compute-vtmsgs (class subclass chain-head)
+(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
   (:documentation
    "Return a VTMSGS object containing method entries for CLASS.
 
@@ -382,6 +392,8 @@
   ((class :initarg :class :type sod-class :reader vtable-class)
    (chain-head :initarg :chain-head :type sod-class
 	       :reader vtable-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+	       :reader vtable-chain-tail)
    (body :initarg :body :type list :reader vtable-body))
   (:documentation
    "VTABLEs hold all of the per-chain static information for a class.
@@ -416,16 +428,18 @@
 (defmethod compute-vtmsgs
     ((class sod-class)
      (subclass sod-class)
-     (chain-head sod-class))
+     (chain-head sod-class)
+     (chain-tail sod-class))
   (flet ((make-entry (message)
 	   (let ((method (find message
 			       (sod-class-effective-methods subclass)
 			       :key #'effective-method-message)))
-	     (make-method-entry method chain-head))))
+	     (make-method-entry method chain-head chain-tail))))
     (make-instance 'vtmsgs
 		   :class class
 		   :subclass subclass
 		   :chain-head chain-head
+		   :chain-tail chain-tail
 		   :entries (mapcar #'make-entry
 				    (sod-class-messages class)))))
 
@@ -462,7 +476,7 @@
 (defvar *done-metaclass-chains*)
 (defvar *done-instance-chains*)
 
-(defgeneric compute-vtable-items (class super chain-head emit)
+(defgeneric compute-vtable-items (class super chain-head chain-tail emit)
   (:documentation
    "Emit vtable items for a superclass of CLASS.
 
@@ -482,7 +496,7 @@
 
 (defmethod compute-vtable-items
     ((class sod-class) (super sod-class) (chain-head sod-class)
-     (emit function))
+     (chain-tail sod-class) (emit function))
 
   ;; If this class introduces new metaclass chains, then emit pointers to
   ;; them.
@@ -511,10 +525,52 @@
 
   ;; Finally, if there are interesting methods, emit those too.
   (when (sod-class-messages super)
-    (funcall emit (compute-vtmsgs super class chain-head))))
+    (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
+
+(defun find-root-superclass (class)
+  "Returns the `root' superclass of CLASS.
+
+   The root superclass is the superclass which itself has no direct
+   superclasses.  In universes not based on the provided builtin module, the
+   root class may not be our beloved SodObject; however, there must be one
+   (otherwise the class graph is cyclic, which should be forbidden), and we
+   instist that it be unique."
+
+  ;; The root superclass must be a chain head since the chains partition the
+  ;; superclasses; the root has no superclasses so it can't have a link and
+  ;; must therefore be a head.  This narrows the field down quite a lot.
+  ;;
+  ;; Note!  This function gets called from CHECK-SOD-CLASS before the class's
+  ;; chains have been computed.  Therefore we iterate over the direct
+  ;; superclass's chains rather than the class's own.  This misses a chain
+  ;; only in the case where the class is its own chain head.  There are two
+  ;; subcases: if there are no direct superclasses at all, then the class is
+  ;; its own root; otherwise, it clearly can't be the root and the omission
+  ;; is harmless.
+  (let* ((supers (sod-class-direct-superclasses class))
+	 (roots (if supers
+		    (remove-if #'sod-class-direct-superclasses
+			       (mapcar (lambda (super)
+					 (sod-class-chain-head super))
+				       supers))
+		    (list class))))
+    (cond ((null roots) (error "Class ~A has no root class!" class))
+	  ((cdr roots) (error "Class ~A has multiple root classes ~
+			       ~{~A~#[~; and ~;, ~]~}"
+			      class roots))
+	  (t (car roots)))))
+
+(defun find-root-metaclass (class)
+  "Returns the `root' metaclass of CLASS.
+
+   The root metaclass is the metaclass of the root superclass -- see
+   FIND-ROOT-SUPERCLASS."
+  (sod-class-metaclass (find-root-superclass class)))
 
 (defmethod compute-vtable ((class sod-class) (chain list))
   (let* ((chain-head (car chain))
+	 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+			   :key #'sod-class-chain-head))
 	 (*done-metaclass-chains* nil)
 	 (*done-instance-chains* (list chain-head))
 	 (done-superclasses nil)
@@ -524,17 +580,11 @@
 
       ;; Find the root chain in the metaclass and write a pointer.
       (let* ((metaclass (sod-class-metaclass class))
-	     (metaclass-chains (sod-class-chains metaclass))
-	     (metaclass-chain-heads (mapcar (lambda (chain)
-					      (sod-class-chain-head
-					       (car chain)))
-					    metaclass-chains))
-	     (metaclass-root-chain (find-if-not
-				    #'sod-class-direct-superclasses
-				    metaclass-chain-heads)))
-	(emit (make-class-pointer class chain-head
-				  metaclass metaclass-root-chain))
-	(push metaclass-root-chain *done-metaclass-chains*))
+	     (metaclass-root (find-root-metaclass class))
+	     (metaclass-root-head (sod-class-chain-head metaclass-root)))
+	(emit (make-class-pointer class chain-head metaclass
+				  metaclass-root-head))
+	(push metaclass-root-head *done-metaclass-chains*))
 
       ;; Write an offset to the instance base.
       (emit (make-base-offset class chain-head))
@@ -548,6 +598,7 @@
 	    (compute-vtable-items class
 				  sub
 				  chain-head
+				  chain-tail
 				  #'emit)
 	    (push sub done-superclasses))))
 
@@ -555,6 +606,7 @@
       (make-instance 'vtable
 		     :class class
 		     :chain-head chain-head
+		     :chain-tail chain-tail
 		     :body (nreverse items)))))
 
 (defgeneric compute-effective-methods (class)
@@ -582,7 +634,10 @@
   (format nil "~A__islots" class))
 
 (defun ichain-struct-tag (class chain-head)
-  (format nil "~A__ichain_~A" class(sod-class-nickname chain-head)))
+  (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
+
+(defun ichain-union-tag (class chain-head)
+  (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
 
 (defun ilayout-struct-tag (class)
   (format nil "~A__ilayout" class))
@@ -596,28 +651,4 @@
 (defun vtable-name (class chain-head)
   (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
 
-;;;--------------------------------------------------------------------------
-;;; Hacks for now.
-
-(defclass hacky-effective-method (effective-method)
-  ((direct-methods :initarg :direct-methods)))
-
-(defmethod print-object ((method hacky-effective-method) stream)
-  (if *print-escape*
-      (print-unreadable-object (method stream :type t)
-	(format stream "~A ~_~A ~_~:<~@{~S~^ ~_~}~:>"
-		(effective-method-message method)
-		(effective-method-class method)
-		(slot-value method 'direct-methods)))
-      (call-next-method)))
-
-(defmethod message-effective-method-class ((message sod-message))
-  'hacky-effective-method)
-
-(defmethod make-method-entry
-    ((method hacky-effective-method) (chain-head sod-class))
-  (make-instance 'method-entry
-		 :method method
-		 :chain-head chain-head))
-
 ;;;----- That's all, folks --------------------------------------------------