;;; -*-lisp-*-
;;;
;;; Class layout protocol
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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 slot objects.

(export '(effective-slot effective-slot-class
	  effective-slot-direct-slot effective-slot-initializer))
(defclass effective-slot ()
  ((%class :initarg :class :type sod-class :reader effective-slot-class)
   (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
   (initializer :initarg :initializer :type (or sod-initializer null)
		:reader effective-slot-initializer)
   (initargs :initarg :initargs :initform nil
	     :type list :reader effective-slot-initargs))
  (:documentation
   "Describes a slot and how it's meant to be initialized.

   Specifically, an effective slot object states that in an instance of
   CLASS, a particular SLOT is initializd by a particular INITIALIZER.  Note
   that the CLASS is a subclass of the SLOT's defining class, and not
   necessarily the same.

   Effective slot objects are usually found in `islots' objects."))

(export 'find-slot-initializer)
(defgeneric find-slot-initializer (class slot)
  (:documentation
   "Return the most specific initializer for SLOT, starting from CLASS."))

(export 'find-slot-initargs)
(defgeneric find-slot-initargs (class slot)
  (:documentation
   "Return as a list all of the initargs defined on CLASS to initialize SLOT.

   The list is returned with initargs defined on more specific classes
   first."))

(export 'compute-effective-slot)
(defgeneric compute-effective-slot (class slot)
  (:documentation
   "Construct an effective slot from the supplied direct slot.

   SLOT is a direct slot defined on CLASS or one of its superclasses.
   (Metaclass initializers are handled using a different mechanism.)"))

;;;--------------------------------------------------------------------------
;;; Instance layout.

;;; islots

(export '(islots islots-class islots-subclass islots-slots))
(defclass islots ()
  ((%class :initarg :class :type sod-class :reader islots-class)
   (subclass :initarg :subclass :type sod-class :reader islots-subclass)
   (slots :initarg :slots :type list :reader islots-slots))
  (:documentation
   "Contains effective slot definitions for a class's direct slots.

   In detail: SLOTS is a list of effective slot objects corresponding to
   CLASS's direct slots, and containing initializers computed relative to
   SUBCLASS."))

(export 'compute-islots)
(defgeneric compute-islots (class subclass)
  (:documentation
   "Return `islots' for a particular CLASS and SUBCLASS.

   Initializers for the slots should be taken from the most specific
   superclass of SUBCLASS."))

;;; vtable-pointer

(export '(vtable-pointer vtable-pointer-class
	  vtable-pointer-chain-head vtable-pointer-chain-tail))
(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)
   (chain-tail :initarg :chain-tail :type sod-class
	       :reader vtable-pointer-chain-tail))
  (:documentation
   "Represents a pointer to a class's vtable.

   There's one of these for each of CLASS's chains.  This particular one
   belongs to the chain headed by CHAIN-HEAD; the most specific superclass of
   CLASS on that chain is CHAIN-TAIL.  (The tail is useful because we can --
   and do -- use structure types defined by the tail class for non-primary
   chains.)"))

;;; ichain

(export '(ichain ichain-class ichain-head ichain-tail ichain-body))
(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
   "Contains instance data for a particular chain of superclasses.

   In detail: describes instance data for one of CLASS's chains, specifically
   the chain headed by CHAIN-HEAD.  The CHAIN-TAIL is the most specific
   superclass of CLASS on the chain in question.  The BODY is a list of
   layout objects to be included.

   An `ilayout' object maintains a list of `ichain' objects, one for each of
   a class's chains."))

(export 'compute-ichain)
(defgeneric compute-ichain (class chain)
  (:documentation
   "Return an ICHAIN for a particular CHAIN of CLASS's superclasses.

   The CHAIN is a list of classes, with the least specific first -- so the
   chain head is the first element."))

;;; ilayout

(export '(ilayout ilayout-class ilayout-ichains))
(defclass ilayout ()
  ((%class :initarg :class :type sod-class :reader ilayout-class)
   (ichains :initarg :ichains :type list :reader ilayout-ichains))
  (:documentation
   "All of the instance layout for a class.

   Describes the layout of an instance of CLASS.  The list ICHAINS contains
   an `ichain' object for each chain of CLASS."))

(export 'compute-ilayout)
(defgeneric compute-ilayout (class)
  (:documentation
   "Compute and return an instance layout for CLASS."))

;;;--------------------------------------------------------------------------
;;; Vtable layout.

;;; vtmsgs

(export '(vtmsgs vtmsgs-class vtmsgs-subclass
	  vtmsgs-chain-head vtmsgs-chain-tail vtmsgs-entries))
(defclass vtmsgs ()
  ((%class :initarg :class :type sod-class :reader vtmsgs-class)
   (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.

   In detail, this lists the `method-entry' objects for the messages defined
   by a particular CLASS, where the effective methods are specialized for the
   SUBCLASS; the method entries adjust the instance pointer argument
   appropriately for a call via the vtable for the chain headed by
   CHAIN-HEAD.  The CHAIN-TAIL is the most specific superclass of SUBCLASS on
   this chain.  The ENTRIES are a list of `method-entry' objects."))

(export 'compute-vtmsgs)
(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
  (:documentation
   "Return a `vtmsgs' object containing method entries for CLASS.

   The CHAIN-HEAD describes which chain the method entries should be
   constructed for.

   The default method simply calls `make-method-entry' for each of the
   methods and wraps a `vtmsgs' object around them.  This ought to be enough
   for almost all purposes."))

;;; class-pointer

(export '(class-pointer class-pointer-class class-pointer-chain-head
	  class-pointer-metaclass class-pointer-meta-chain-head))
(defclass class-pointer ()
  ((%class :initarg :class :type sod-class :reader class-pointer-class)
   (chain-head :initarg :chain-head :type sod-class
	       :reader class-pointer-chain-head)
   (metaclass :initarg :metaclass :type sod-class
	      :reader class-pointer-metaclass)
   (meta-chain-head :initarg :meta-chain-head :type sod-class
		    :reader class-pointer-meta-chain-head))
  (:documentation
   "Represents a pointer to a class object for the instance's class.

   This is somewhat complicated because there are two degrees of freedom.  An
   instance of `class-pointer' is a pointer from a vtable to an `ichain' of
   the the class's metaclass instance.  In particular, a `class-pointer'
   instance represents a pointer in a vtable constructed for CLASS and
   attached to the chain headed by CHAIN-HEAD; it points to an instance of
   METACLASS, and specifically to the `ichain' substructure corresponding to
   the chain headed by META-CHAIN-HEAD, which will be a superclass of
   METACLASS.

   I'm sorry if this is confusing."))

(export 'make-class-pointer)
(defgeneric make-class-pointer (class chain-head metaclass meta-chain-head)
  (:documentation
   "Return a class pointer to a metaclass chain."))

;;; base-offset

(export '(base-offset base-offset-class base-offset-chain-head))
(defclass base-offset ()
  ((%class :initarg :class :type sod-class :reader base-offset-class)
   (chain-head :initarg :chain-head :type sod-class
	       :reader base-offset-chain-head))
  (:documentation
   "The offset of this chain to the `ilayout' base.

   We're generating a vtable for CLASS, attached to the chain headed by
   CHAIN-HEAD.  Fortunately (and unlike `class-pointer'), the chain head can
   do double duty, since it also identifies the `ichain' substructure of the
   class's `ilayout' whose offset we're interested in."))

(export 'make-base-offset)
(defgeneric make-base-offset (class chain-head)
  (:documentation
   "Return the base offset object for CHAIN-HEAD ichain."))

;;; chain-offset

(export '(chain-offset chain-offset-class
	  chain-offset-chain-head chain-offset-target-head))
(defclass chain-offset ()
  ((%class :initarg :class :type sod-class :reader chain-offset-class)
   (chain-head :initarg :chain-head :type sod-class
	       :reader chain-offset-chain-head)
   (target-head :initarg :target-head :type sod-class
		:reader chain-offset-target-head))
  (:documentation
   "The offset to a different `ichain'.

   We're generating a vtable for CLASS, attached to the chain headed by
   CHAIN-HEAD.  This instance represents an offset to the (different) chain
   headed by TARGET-HEAD.

   This is, strictly speaking, redundant.  We could do as well by using the
   base offset and finding the offset to the target class in the class
   object's metadata; but that would either require a search or we'd have to
   be able work out the target chain's index in the table."))

(defgeneric make-chain-offset (class chain-head target-head)
  (:documentation
   "Return the offset from CHAIN-HEAD to TARGET-HEAD."))

;;; vtable

(export '(vtable vtable-class vtable-body
	  vtable-chain-head vtable-chain-tail))
(defclass vtable ()
  ((%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
   "A vtable holds all of the per-chain static information for a class.

   Each chain of CLASS has its own vtable; the `vtable' object remembers the
   least specific (CHAIN-HEAD) and most specific (CHAIN-TAIL) superclasses of
   CLASS on that chain.  (This is useful because we can reuse vtable
   structure types from superclasses for chains other than the primary chain
   -- i.e., the one in which CLASS itself appears.)

   The BODY is a list of vtable items, including `vtmsgs' structures,
   `chain-offset's, `class-pointers', and a `base-offset'."))

(export 'compute-vtable-items)
(defgeneric compute-vtable-items (class super chain-head chain-tail emit)
  (:documentation
   "Emit vtable items for a superclass of CLASS.

   This function is called for each superclass SUPER of CLASS reached on the
   chain headed by CHAIN-HEAD.  The function should call EMIT for each
   vtable item it wants to write.

   The right way to check to see whether items have already been emitted
   (e.g., has an offset to some other chain been emitted?) is as follows:

     * In a method (ideally an `:around'-method) on `compute-vtable', bind a
       special variable to an empty list or hash table.

     * In a method on this function, check the variable or hash table.

   This function is the real business end of `compute-vtable'."))

(export 'compute-vtable)
(defgeneric compute-vtable (class chain)
  (:documentation
   "Compute the vtable layout for a chain of CLASS.

   The CHAIN is a list of classes, with the least specific first.

   There is a default method which invokes `compute-vtable-items' to do the
   difficult work."))

(export 'compute-vtables)
(defgeneric compute-vtables (class)
  (:documentation
   "Compute the vtable layouts for CLASS.

   Returns a list of VTABLE objects in the order of CLASS's chains."))

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