--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Class layout protocol implementation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Effective slots.
+
+(defmethod print-object ((slot effective-slot) stream)
+ (maybe-print-unreadable-object (slot stream :type t)
+ (format stream "~A~@[ = ~@_~A~]"
+ (effective-slot-direct-slot slot)
+ (effective-slot-initializer slot))))
+
+(defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
+ (some (lambda (super)
+ (find slot
+ (sod-class-instance-initializers super)
+ :key #'sod-initializer-slot))
+ (sod-class-precedence-list class)))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
+ (make-instance 'effective-slot
+ :slot slot
+ :class class
+ :initializer (find-slot-initializer class slot)))
+
+;;;--------------------------------------------------------------------------
+;;; Special-purpose slot objects.
+
+(export 'sod-class-slot)
+(defclass sod-class-slot (sod-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader sod-slot-initializer-function)
+ (prepare-function :initarg :prepare-function :type (or symbol function)
+ :reader sod-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on SodClass.
+
+ These slots need class-specific initialization. It's easier to keep all
+ of the information (name, type, and how to initialize them) about these
+ slots in one place, so that's what we do here."))
+
+(defmethod shared-initialize :after
+ ((slot sod-class-slot) slot-names &key pset)
+ (declare (ignore slot-names))
+ (default-slot (slot 'initializer-function)
+ (get-property pset :initializer-function t nil))
+ (default-slot (slot 'prepare-function)
+ (get-property pset :prepare-function t nil)))
+
+(export 'sod-class-effective-slot)
+(defclass sod-class-effective-slot (effective-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader effective-slot-initializer-function)
+ (prepare-function :initarg :prepare-function :type (or symbol function)
+ :reader effective-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on SodClass.
+
+ This class ignores any explicit initializers and computes initializer
+ values using the slot's INIT-FUNC slot and a magical protocol during
+ metaclass instance construction."))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
+ (make-instance 'sod-class-effective-slot
+ :class class :slot slot
+ :initializer-function (sod-slot-initializer-function slot)
+ :prepare-function (sod-slot-prepare-function slot)
+ :initializer (find-slot-initializer class slot)))
+
+;;;--------------------------------------------------------------------------
+;;; Effective methods.
+
+(defmethod print-object ((method effective-method) stream)
+ (maybe-print-unreadable-object (method stream :type t)
+ (format stream "~A ~A"
+ (effective-method-message method)
+ (effective-method-class method))))
+
+(defmethod print-object ((entry method-entry) stream)
+ (maybe-print-unreadable-object (entry stream :type t)
+ (format stream "~A:~A"
+ (method-entry-effective-method entry)
+ (sod-class-nickname (method-entry-chain-head entry)))))
+
+(defmethod compute-sod-effective-method
+ ((message sod-message) (class sod-class))
+ (let ((direct-methods (mappend (lambda (super)
+ (remove message
+ (sod-class-methods super)
+ :key #'sod-method-message
+ :test-not #'eql))
+ (sod-class-precedence-list class))))
+ (make-instance (message-effective-method-class message)
+ :message message
+ :class class
+ :direct-methods direct-methods)))
+
+(defmethod compute-effective-methods ((class sod-class))
+ (mapcan (lambda (super)
+ (mapcar (lambda (message)
+ (compute-sod-effective-method message class))
+ (sod-class-messages super)))
+ (sod-class-precedence-list class)))
+
+(defmethod slot-unbound
+ (clos-class (class sod-class) (slot-name (eql 'effective-methods)))
+ (setf (slot-value class 'effective-methods)
+ (compute-effective-methods class)))
+
+;;;--------------------------------------------------------------------------
+;;; Instance layout.
+
+;;; islots
+
+(defmethod print-object ((islots islots) stream)
+ (print-unreadable-object (islots stream :type t)
+ (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
+ (islots-subclass islots)
+ (islots-class islots)
+ (islots-slots islots))))
+
+(defmethod compute-islots ((class sod-class) (subclass sod-class))
+ (make-instance 'islots
+ :class class
+ :subclass subclass
+ :slots (mapcar (lambda (slot)
+ (compute-effective-slot subclass slot))
+ (sod-class-slots class))))
+
+;;; vtable-pointer
+;;; Do we need a construction protocol here?
+
+(defmethod print-object ((vtp vtable-pointer) stream)
+ (print-unreadable-object (vtp stream :type t)
+ (format stream "~A:~A"
+ (vtable-pointer-class vtp)
+ (sod-class-nickname (vtable-pointer-chain-head vtp)))))
+
+;;; ichain
+
+(defmethod print-object ((ichain ichain) stream)
+ (print-unreadable-object (ichain stream :type t)
+ (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
+ (ichain-class ichain)
+ (sod-class-nickname (ichain-head ichain))
+ (ichain-body ichain))))
+
+(defmethod compute-ichain ((class sod-class) 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 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 chain-head
+ :chain-tail chain-tail
+ :body (cons vtable-pointer islots))))
+
+;;; ilayout
+
+(defmethod print-object ((ilayout ilayout) stream)
+ (print-unreadable-object (ilayout stream :type t)
+ (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
+ (ilayout-class ilayout)
+ (ilayout-ichains ilayout))))
+
+(defmethod compute-ilayout ((class sod-class))
+ (make-instance 'ilayout
+ :class class
+ :ichains (mapcar (lambda (chain)
+ (compute-ichain class
+ (reverse chain)))
+ (sod-class-chains class))))
+
+(defmethod slot-unbound
+ (clos-class (class sod-class) (slot-name (eql 'ilayout)))
+ (setf (slot-value class 'ilayout)
+ (compute-ilayout class)))
+
+;;;--------------------------------------------------------------------------
+;;; Vtable layout.
+
+;;; vtmsgs
+
+(defmethod print-object ((vtmsgs vtmsgs) stream)
+ (print-unreadable-object (vtmsgs stream :type t)
+ (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
+ (vtmsgs-subclass vtmsgs)
+ (vtmsgs-class vtmsgs)
+ (vtmsgs-entries vtmsgs))))
+
+(defmethod compute-vtmsgs
+ ((class sod-class)
+ (subclass 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 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)))))
+
+;;; class-pointer
+
+(defmethod print-object ((cptr class-pointer) stream)
+ (print-unreadable-object (cptr stream :type t)
+ (format stream "~A:~A"
+ (class-pointer-metaclass cptr)
+ (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
+
+(defmethod make-class-pointer
+ ((class sod-class) (chain-head sod-class)
+ (metaclass sod-class) (meta-chain-head sod-class))
+
+ ;; Slightly tricky. We don't necessarily want a pointer to the metaclass,
+ ;; but to its most specific subclass on the given chain. Fortunately, CL
+ ;; is good at this game.
+ (let* ((meta-chains (sod-class-chains metaclass))
+ (meta-chain-tails (mapcar #'car meta-chains))
+ (meta-chain-tail (find meta-chain-head meta-chain-tails
+ :key #'sod-class-chain-head)))
+ (make-instance 'class-pointer
+ :class class
+ :chain-head chain-head
+ :metaclass meta-chain-tail
+ :meta-chain-head meta-chain-head)))
+
+;;; base-offset
+
+(defmethod print-object ((boff base-offset) stream)
+ (print-unreadable-object (boff stream :type t)
+ (format stream "~A:~A"
+ (base-offset-class boff)
+ (sod-class-nickname (base-offset-chain-head boff)))))
+
+(defmethod make-base-offset ((class sod-class) (chain-head sod-class))
+ (make-instance 'base-offset
+ :class class
+ :chain-head chain-head))
+
+;;; chain-offset
+
+(defmethod print-object ((choff chain-offset) stream)
+ (print-unreadable-object (choff stream :type t)
+ (format stream "~A:~A->~A"
+ (chain-offset-class choff)
+ (sod-class-nickname (chain-offset-chain-head choff))
+ (sod-class-nickname (chain-offset-target-head choff)))))
+
+(defmethod make-chain-offset
+ ((class sod-class) (chain-head sod-class) (target-head sod-class))
+ (make-instance 'chain-offset
+ :class class
+ :chain-head chain-head
+ :target-head target-head))
+
+;;; vtable
+
+(defmethod print-object ((vtable vtable) stream)
+ (print-unreadable-object (vtable stream :type t)
+ (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
+ (vtable-class vtable)
+ (sod-class-nickname (vtable-chain-head vtable))
+ (vtable-body vtable))))
+
+;; Special variables used by `compute-vtable'.
+(defvar *done-metaclass-chains*)
+(defvar *done-instance-chains*)
+
+(defmethod compute-vtable-items
+ ((class sod-class) (super sod-class) (chain-head sod-class)
+ (chain-tail sod-class) (emit function))
+
+ ;; If this class introduces new metaclass chains, then emit pointers to
+ ;; them.
+ (let* ((metasuper (sod-class-metaclass super))
+ (metasuper-chains (sod-class-chains metasuper))
+ (metasuper-chain-heads (mapcar (lambda (chain)
+ (sod-class-chain-head (car chain)))
+ metasuper-chains)))
+ (dolist (metasuper-chain-head metasuper-chain-heads)
+ (unless (member metasuper-chain-head *done-metaclass-chains*)
+ (funcall emit (make-class-pointer class
+ chain-head
+ metasuper
+ metasuper-chain-head))
+ (push metasuper-chain-head *done-metaclass-chains*))))
+
+ ;; If there are new instance chains, then emit offsets to them.
+ (let* ((chains (sod-class-chains super))
+ (chain-heads (mapcar (lambda (chain)
+ (sod-class-chain-head (car chain)))
+ chains)))
+ (dolist (head chain-heads)
+ (unless (member head *done-instance-chains*)
+ (funcall emit (make-chain-offset class chain-head head))
+ (push head *done-instance-chains*))))
+
+ ;; Finally, if there are interesting methods, emit those too.
+ (when (sod-class-messages super)
+ (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
+
+(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)
+ (items nil))
+ (flet ((emit (item)
+ (push item items)))
+
+ ;; Find the root chain in the metaclass and write a pointer.
+ (let* ((metaclass (sod-class-metaclass class))
+ (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))
+
+ ;; Now walk the chain. As we ascend the chain, scan the class
+ ;; precedence list of each class in reverse to ensure that we have
+ ;; everything interesting.
+ (dolist (super chain)
+ (dolist (sub (reverse (sod-class-precedence-list super)))
+ (unless (member sub done-superclasses)
+ (compute-vtable-items class
+ sub
+ chain-head
+ chain-tail
+ #'emit)
+ (push sub done-superclasses))))
+
+ ;; We're through.
+ (make-instance 'vtable
+ :class class
+ :chain-head chain-head
+ :chain-tail chain-tail
+ :body (nreverse items)))))
+
+(defmethod compute-vtables ((class sod-class))
+ (mapcar (lambda (chain)
+ (compute-vtable class (reverse chain)))
+ (sod-class-chains class)))
+
+(defmethod slot-unbound
+ (clos-class (class sod-class) (slot-name (eql 'vtables)))
+ (setf (slot-value class 'vtables)
+ (compute-vtables class)))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff