[sod] / src / class-layout-impl.lisp

;;; -*-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 :func nil))
  (default-slot (slot 'prepare-function)
    (get-property pset :prepare-function :func 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~@[ ~S~]"
            (method-entry-effective-method entry)
            (sod-class-nickname (method-entry-chain-head entry))
            (method-entry-role 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)))
  (declare (ignore clos-class))
  (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)))
  (declare (ignore clos-class))
  (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-entries (message)
           (let ((method (find message
                               (sod-class-effective-methods subclass)
                               :key #'effective-method-message)))
             (make-method-entries method chain-head chain-tail))))
    (make-instance 'vtmsgs
                   :class class
                   :subclass subclass
                   :chain-head chain-head
                   :chain-tail chain-tail
                   :entries (mapcan #'make-entries
                                    (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)))
  (declare (ignore clos-class))
  (setf (slot-value class 'vtables)
        (compute-vtables class)))

;;;----- That's all, folks --------------------------------------------------