+++ /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