(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."))
(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.
(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))
(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.
(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.
(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)
(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.
((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.
(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)))))
(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.
(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.
;; 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)
;; 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))
(compute-vtable-items class
sub
chain-head
+ chain-tail
#'emit)
(push sub done-superclasses))))
(make-instance 'vtable
:class class
:chain-head chain-head
+ :chain-tail chain-tail
:body (nreverse items)))))
(defgeneric compute-effective-methods (class)
(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))
(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 --------------------------------------------------
~mdw / sod / blobdiff