[sod] / class-defs.lisp

;;; -*-lisp-*-
;;;
;;; Basic definitions for classes, methods and suchlike
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; 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)

;;;--------------------------------------------------------------------------
;;; Class definitions.

(defclass sod-class ()
  ((name :initarg :name
         :type string
         :reader sod-class-name)
   (location :initarg :location
             :initform (file-location nil)
             :type file-location
             :reader file-location)
   (nickname :initarg :nick
             :type string
             :reader sod-class-nickname)
   (direct-superclasses :initarg :superclasses
                        :type list
                        :reader sod-class-direct-superclasses)
   (chained-superclass :initarg :chain-to
                       :type (or sod-class null)
                       :reader sod-class-chained-superclass)
   (metaclass :initarg :metaclass
              :type sod-class
              :reader sod-class-metaclass)
   (slots :initarg :slots
          :type list
          :initform nil
          :accessor sod-class-slots)
   (instance-initializers :initarg :instance-initializers
                          :type list
                          :initform nil
                          :accessor sod-class-instance-initializers)
   (class-initializers :initarg :class-initializers
                       :type list
                       :initform nil
                       :accessor sod-class-class-initializers)
   (messages :initarg :messages
             :type list
             :initform nil
             :accessor sod-class-messages)
   (methods :initarg :methods
            :type list
            :initform nil
            :accessor sod-class-methods)

   (class-precedence-list :type list :accessor sod-class-precedence-list)

   (chain-head :type sod-class :accessor sod-class-chain-head)
   (chain :type list :accessor sod-class-chain)
   (chains :type list :accessor sod-class-chains)

   (state :initform nil
          :type (member nil :finalized broken)
          :accessor sod-class-state))
  (:documentation
   "Classes describe the layout and behaviour of objects.

   The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAINED-SUPERCLASS and
   METACLASS slots are intended to be initialized when the class object is
   constructed:

     * The NAME is the identifier associated with the class in the user's
       source file.  It is used verbatim in the generated C code as a type
       name, and must be distinct from other file-scope names in any source
       file which includes the class definition.  Furthermore, other names
       are derived from the class name (most notably the class object
       NAME__class), which have external linkage and must therefore be
       distinct from all other identifiers in the program.  It is forbidden
       for a class NAME to begin with an underscore or to contain two
       consecutive underscores.

     * The LOCATION identifies where in the source the class was defined.  It
       gets used in error messages.

     * The NICKNAME is a shorter identifier used to name the class in some
       circumstances.  The uniqueness requirements on NICKNAME are less
       strict, which allows them to be shorter: no class may have two classes
       with the same nickname on its class precedence list.  Nicknames are
       used (user-visibly) to distinguish slots and messages defined by
       different classes, and (invisibly) in the derived names of direct
       methods.  It is forbidden for a nickname to begin with an underscore,
       or to contain two consecutive underscores.

     * The DIRECT-SUPERCLASSES are a list of the class's direct superclasses,
       in the order that they were declared in the source.  The class
       precedence list is computed from the DIRECT-SUPERCLASSES lists of all
       of the superclasses involved.

     * The CHAINED-SUPERCLASS is either NIL or one of the
       DIRECT-SUPERCLASSES.  Class chains are a means for recovering most of
       the benefits of simple hierarchy lost by the introduction of multiple
       inheritance.  A class's superclasses (including itself) are
       partitioned into chains, consisting of a class, its CHAINED-
       SUPERCLASS, that class's CHAINED-SUPERCLASS, and so on.  It is an
       error if two direct subclasses of any class appear in the same
       chain (a global property which requires global knowledge of an entire
       program's class hierarchy in order to determine sensibly).  Slots of
       superclasses in the same chain can be accessed efficiently; there is
       an indirection needed to access slots of superclasses in other chains.
       Furthermore, an indirection is required to perform a cross-chain
       conversion (i.e., converting a pointer to an instance of some class
       into a pointer to an instance of one of its superclasses in a
       different chain), an operation which occurs implicitly in effective
       methods in order to call direct methods defined on cross-chain
       superclasses.

     * The METACLASS is the class of the class object.  Classes are objects
       in their own right, and therefore must be instances of some class;
       this class is the metaclass.  Metaclasses can define additional slots
       and methods to be provided by their instances; a class definition can
       provide (C constant expression) initial values for the metaclass
       instance.

   The next few slots can't usually be set at object-construction time, since
   the objects need to contain references to the class object itself.

     * The SLOTS are a list of the slots defined by the class (instances of
       SOD-SLOT).  (The class will also define all of the slots defined by
       its superclasses.)

     * The INSTANCE-INITIALIZERS and CLASS-INITIALIZERS are lists of
       initializers for slots (see SOD-INITIALIZER and subclasses), providing
       initial values for instances of the class, and for the class's class
       object itself, respectively.

     * The MESSAGES are a list of the messages recognized by the class
       (instances of SOD-MESSAGE and subclasses).  (Note that the message
       need not have any methods defined on it.  The class will also
       recognize all of the messages defined by its superclasses.)

     * The METHODS are a list of (direct) methods defined on the class
       (instances of SOD-METHOD and subclasses).  Each method provides
       behaviour to be invoked by a particular message recognized by the
       class.

   Other slots are computed from these in order to describe the class's
   layout and effective methods; this is done by FINALIZE-SOD-CLASS.

   FIXME: Add the necessary slots and describe them."))

(defmethod print-object ((class sod-class) stream)
  (print-unreadable-object (class stream :type t)
    (prin1 (sod-class-name class) stream)))

(defclass sod-message ()
  ((name :initarg :name
         :type string
         :reader sod-message-name)
   (location :initarg :location
             :initform (file-location nil)
             :type file-location
             :reader file-location)
   (class :initarg :class
          :type sod-class
          :reader sod-message-class)
   (type :initarg :type
         :type c-function-type
         :reader sod-message-type))
  (:documentation
   "Messages the means for stimulating an object to behave.

   SOD is a single-dispatch object system, like Smalltalk, C++, Python and so
   on, but unlike CLOS and Dylan.  Behaviour is invoked by `sending messages'
   to objects.  A message carries a name (distinguishing it from other
   messages recognized by the same class), and a number of arguments; the
   object may return a value in response.  Sending a message therefore looks
   very much like calling a function; indeed, each message bears the static
   TYPE signature of a function.

   An object reacts to being sent a message by executing an `effective
   method', constructed from the direct methods defined on the recpient's
   (run-time, not necessarily statically-declared) class and its superclasses
   according to the message's `method combination'.

   Much interesting work is done by subclasses of SOD-MESSAGE, which (for
   example) specify method combinations.

   The slots are as follows.

     * The NAME distinguishes the message from others defined by the same
       class.  Unlike most (all?) other object systems, messages defined in
       different classes are in distinct namespaces.  It is forbidden for a
       message name to begin with an underscore, or to contain two
       consecutive underscores.  (Final underscores are fine.)

     * The LOCATION states where in the user's source the slot was defined.
       It gets used in error messages.

     * The CLASS states which class defined the message.

     * The TYPE is a function type describing the message's arguments and
       return type.

   Subclasses can (and probably will) define additional slots."))

(defclass sod-method ()
  ((message :initarg :message
            :type sod-message
            :reader sod-method-message)
   (location :initarg :location
             :initform (file-location nil)
             :type file-location
             :reader file-location)
   (class :initarg :class
          :type sod-class
          :reader sod-method-class)
   (type :initarg :type
         :type c-function-type
         :reader sod-method-type)
   (body :initarg :body
         :type (or c-fragment null)
         :reader sod-method-body))
  (:documentation
   "(Direct) methods are units of behaviour.

   Methods are the unit of behaviour in SOD.  Classes define direct methods
   for particular messages.

   When a message is received by an instance, all of the methods defined for
   that message on that instance's (run-time, not static) class and its
   superclasses are `applicable'.  The applicable methods are gathered
   together and invoked in some way; the details of this are left to the
   `method combination', determined by the subclass of SOD-MESSAGE.

   The slots are as follows.

     * The MESSAGE describes which meessage invokes the method's behaviour.
       The method is combined with other methods on the same message
       according to the message's method combination, to form an `effective
       method'.

     * The LOCATION states where, in the user's source, the method was
       defined.  This gets used in error messages.  (Depending on the user's
       coding style, this location might be subtly different from the BODY's
       location.)

     * The CLASS specifies which class defined the method.  This will be
       either the class of the message, or one of its descendents.

     * The TYPE gives the type of the method, including its arguments.  This
       will, in general, differ from the type of the message for several
       reasons.

         -- Firstly, the method type must include names for all of the
            method's parameters.  The message definition can omit the
            parameter names (in the same way as a function declaration can).
            Formally, the message definition can contain abstract
            declarators, whereas method definitions must not.

         -- Method combinations may require different parameter or return
            types.  For example, `before' and `after' methods don't
            contribute to the message's return value, so they must be defined
            as returning `void'.

         -- Method combinations may permit methods whose parameter and/or
            return types don't exactly match the corresponding types of the
            message.  For example, one might have methods with covariant
            return types and contravariant parameter types.  (This sounds
            nice, but it doesn't actually seem like such a clever idea when
            you consider that the co-/contravariance must hold among all the
            applicable methods ordered according to the class precedence
            list.  As a result, a user might have to work hard to build
            subclasses whose CPLs match the restrictions implied by the
            method types.)

   Method objects are fairly passive in the SOD translator.  However,
   subclasses of SOD-MESSAGE may (and probably will) construct instances of
   subclasses of SOD-METHOD in order to carry the additional metadata they
   need to keep track of."))

(defclass sod-slot ()
  ((name :initarg :name
         :type string
         :reader sod-slot-name)
   (location :initarg :location
             :initform (file-location nil)
             :type file-location
             :reader file-location)
   (class :initarg :class
          :type sod-class
          :reader sod-slot-class)
   (type :initarg :type
         :type c-type
         :reader sod-slot-type))
  (:documentation
   "Slots are units of information storage in instances.

   Each class defines a number of slots, which function similarly to (data)
   members in structures.  An instance contains all of the slots defined in
   its class and all of its superclasses.

   A slot carries the following information.

     * A NAME, which distinguishes it from other slots defined by the same
       class.  Unlike most (all?) other object systems, slots defined in
       different classes are in distinct namespaces.  There are no special
       restrictions on slot names.

     * A LOCATION, which states where in the user's source the slot was
       defined.  This gets used in error messages.

     * A CLASS, which states which class defined the slot.  The slot is
       available in instances of this class and all of its descendents.

     * A TYPE, which is the C type of the slot.  This must be an object type
       (certainly not a function type, and it must be a complete type by the
       time that the user header code has been scanned)."))

(defclass sod-initializer ()
  ((slot :initarg :slot
         :type sod-slot
         :reader sod-initializer-slot)
   (location :initarg :location
             :initform (file-location nil)
             :type file-location
             :reader file-location)
   (class :initarg :class
          :type sod-class
          :reader sod-initializer-clas)
   (value-kind :initarg :value-kind
               :type keyword
               :reader sod-initializer-value-kind)
   (value-form :initarg :value-form
               :type c-fragment
               :reader sod-initializer-value-form))
  (:documentation
   "Provides an initial value for a slot.

   The slots of an initializer are as follows.

     * The SLOT specifies which slot this initializer is meant to initialize.

     * The LOCATION states the position in the user's source file where the
       initializer was found.  This gets used in error messages.  (Depending
       on the source layout style, this might differ from the location in the
       VALUE-FORM C fragment.)

     * The CLASS states which class defined this initializer.  For instance
       slot initializers (SOD-INSTANCE-INITIALIZER), this will be the same as
       the SLOT's class, or be one of its descendants.  For class slot
       initializers (SOD-CLASS-INITIALIZER), this will be an instance of the
       SLOT's class, or an instance of one of its descendants.

     * The VALUE-KIND states what manner of initializer we have.  It can be
       either :SINGLE, indicating a standalone expression, or :COMPOUND,
       indicating a compound initializer which must be surrounded by braces
       on output.

     * The VALUE-FORM gives the text of the initializer, as a C fragment.

   Typically you'll see instances of subclasses of this class in the wild
   rather than instances of this class directly.  See SOD-CLASS-INITIALIZER
   and SOD-INSTANCE-INITIALIZER."))

(defclass sod-class-initializer (sod-initializer)
  ()
  (:documentation
   "Provides an initial value for a class slot.

   A class slot initializer provides an initial value for a slot in the class
   object (i.e., one of the slots defined by the class's metaclass).  Its
   VALUE-FORM must have the syntax of an initializer, and its consituent
   expressions must be constant expressions.

   See SOD-INITIALIZER for more details."))

(defclass sod-instance-initializer (sod-initializer)
  ()
  (:documentation
   "Provides an initial value for a slot in all instances.

   An instance slot initializer provides an initial value for a slot in
   instances of the class.  Its VALUE-FORM must have the syntax of an
   initializer.  Furthermore, if the slot has aggregate type, then you'd
   better be sure that your compiler supports compound literals (6.5.2.5)
   because that's what the initializer gets turned into.

   See SOD-INITIALIZER for more details."))

;;;--------------------------------------------------------------------------
;;; Classes as C types.

(defclass c-class-type (simple-c-type)
  ((class :initarg :class
          :type (or null sod-class)
          :accessor c-type-class))
  (:documentation
   "A SOD class, as a C type.

   One usually handles classes as pointers, but the type refers to the actual
   instance structure itself.  Or, in fact, just the primary chain of the
   instance (i.e., the one containing the class's own direct slots) -- which
   is why dealing with the instance structure directly doesn't make much
   sense.

   The CLASS slot will be NIL if the class isn't defined yet, i.e., this
   entry was constructed by a forward reference operation.

   The NAME slot inherited from SIMPLE-C-TYPE is here so that we can print
   the type even when it's a forward reference."))

(defmethod c-type-equal-p and ((type-a c-class-type)
                               (type-b c-class-type))
  (eql (c-type-class type-a) (c-type-class type-b)))

(defmethod print-c-type (stream (type c-class-type) &optional colon atsign)
  (declare (ignore colon atsign))
  (format stream "~:@<CLASS ~@_~S~:>" (c-type-name type)))

(defun find-class-type (name &optional floc)
  "Look up NAME and return the corresponding C-CLASS-TYPE.

   Returns two values: TYPE and WINP.

     * If the type was found, and was a class, returns TYPE.

     * If no type was found at all, returns NIL.

     * If a type was found, but it wasn't a class, signals an error at FLOC."

  (with-default-error-location (floc)
    (let ((type (gethash name *type-map*)))
      (typecase type
        (null nil)
        (c-class-type type)
        (t (error "Type `~A' (~A) is not a class" name type))))))

(defun make-class-type (name &optional floc)
  "Return a class type for NAME, creating it if necessary.

   FLOC is the location to use in error reports."
  (multiple-value-bind (type winp) (find-class-type name floc)
    (cond ((not winp) nil)
          (type type)
          (t (setf (gethash name *type-map*)
                   (make-instance 'c-class-type :name name :class nil))))))

(defun find-sod-class (name &optional floc)
  "Return the SOD-CLASS object with the given NAME.

   FLOC is the location to use in error reports."
  (with-default-error-location (floc)
    (multiple-value-bind (type winp) (find-class-type name floc)
      (cond ((not type) (error "Type `~A' not known" name))
            (t (let ((class (c-type-class type)))
                 (unless class
                   (error "Class `~A' is incomplete" name))
                 class))))))

(defun record-sod-class (class &optional (floc class))
  "Record CLASS as being a class definition.

   FLOC is the location to use in error reports."
  (with-default-error-location (floc)
    (let* ((name (sod-class-name class))
           (type (make-class-type name floc)))
      (cond ((null type) nil)
            ((c-type-class type)
             (cerror* "Class `~A' already defined at ~A"
                      name (file-location (c-type-class type))))
            (t
             (setf (c-type-class type) class))))))

(define-c-type-syntax class (name)
  "Returns a type object for the named class."
  (make-class-type (c-name-case name)))

;;;--------------------------------------------------------------------------
;;; Class finalization.

;; Protocol.

(defgeneric compute-chains (class)
  (:documentation
   "Compute the layout chains for CLASS.

   Fills in

     * the head of the class's primary chain;

     * the class's primary chain as a list, most- to least-specific; and

     * the complete collection of chains, as a list of lists, each most- to
       least-specific, with the primary chain first.

   If the chains are ill-formed (i.e., not distinct) then an error is
   reported and the function returns nil; otherwise it returns a true
   value."))

(defgeneric check-sod-class (class)
  (:documentation
   "Check the CLASS for validity.

   This is done as part of class finalization.  The checks performed are as
   follows.

     * The class name and nickname, and the names of messages, obey the
       rules (see VALID-NAME-P).

     * The messages and slots have distinct names.

     * The classes in the class-precedence-list have distinct nicknames.

     * The chained-superclass is actually one of the direct superclasses.

     * The chosen metaclass is actually a subclass of all of the
       superclasses' metaclasses.

   Returns true if all is well; false (and signals errors) if anything was
   wrong."))

(defgeneric finalize-sod-class (class)
  (:documentation
   "Computes all of the gory details about a class.

   Once one has stopped inserting methods and slots and so on into a class,
   one needs to finalize it to determine the layout structure and the class
   precedence list and so on.  More precisely that gets done is this:

     * Related classes (i.e., direct superclasses and the metaclass) are
       finalized if they haven't been already.

     * If you've been naughty and failed to store a list of slots or
       whatever, then an empty list is inserted.

     * The class precedence list is computed and stored.

     * The class is checked for compiance with the well-formedness rules.

     * The layout chains are computed.

   Other stuff will need to happen later, but it's not been done yet.  In
   particular:

     * Actually computing the layout of the instance and the virtual tables.

     * Combining the applicable methods into effective methods.

   FIXME this needs doing."))

;; Implementation.

(defmethod compute-chains ((class sod-class))
  (with-default-error-location (class)
    (let* ((head (with-slots (chained-superclass) class
                   (if chained-superclass
                       (sod-class-chain-head chained-superclass)
                       class)))
           (chain (with-slots (chained-superclass) class
                    (cons class (and chained-superclass
                                     (sod-class-chain chained-superclass)))))
           (chains (list chain)))

      ;; Compute the chains.  This is (unsurprisingly) the hard bit.  The
      ;; chain of this class must either be a new chain or the same as one of
      ;; its superclasses.  Therefore, the chains are well-formed if the
      ;; chains of the superclasses are distinct.  We can therefore scan the
      ;; direct superclasses from left to right as follows.
      (with-slots (direct-superclasses) class
        (let ((table (make-hash-table)))
          (dolist (super direct-superclasses)
            (let* ((head (sod-class-chain-head super))
                   (tail (gethash head table)))
              (cond ((not tail)
                     (setf (gethash head table) super))
                    ((not (sod-subclass-p super tail))
                     (error "Conflicting chains (~A and ~A) in class ~A"
                            (sod-class-name tail)
                            (sod-class-name super)
                            (sod-class-name class)))
                    (t
                     (let ((ch (sod-class-chain super)))
                       (unless (eq ch chain)
                         (push ch chains)))))))))

      ;; Done.
      (values head chain (nreverse chains)))))

(defmethod check-sod-class ((class sod-class))
  (with-default-error-location (class)

    ;; Check the names of things are valid.
    (with-slots (name nickname messages) class
      (unless (valid-name-p name)
        (error "Invalid class name `~A'" name))
      (unless (valid-name-p nickname)
        (error "Invalid class nickname `~A' on class `~A'" nickname name))
      (dolist (message messages)
        (unless (valid-name-p (sod-message-name message))
          (error "Invalid message name `~A' on class `~A'"
                 (sod-message-name message) name))))

      ;; Check that the slots and messages have distinct names.
    (with-slots (name slots messages class-precedence-list) class
      (flet ((check-list (list what namefunc)
               (let ((table (make-hash-table :test #'equal)))
                 (dolist (item list)
                   (let ((itemname (funcall namefunc item)))
                     (if (gethash itemname table)
                         (error "Duplicate ~A name `~A' on class `~A'"
                                what itemname name)
                         (setf (gethash itemname table) item)))))))
        (check-list slots "slot" #'sod-slot-name)
        (check-list messages "message" #'sod-message-name)
        (check-list class-precedence-list "nickname" #'sod-class-name)))

    ;; Check that the CHAIN-TO class is actually a superclass.
    (with-slots (name direct-superclasses chained-superclass) class
      (unless (or (not chained-superclass)
                  (member chained-superclass direct-superclasses))
        (error "In `~A~, chain-to class `~A' is not a direct superclass"
               name (sod-class-name chained-superclass))))

    ;; Check that the metaclass is a subclass of each of the
    ;; superclasses' metaclasses.
    (with-slots (name metaclass direct-superclasses) class
      (dolist (super direct-superclasses)
        (unless (sod-subclass-p metaclass (sod-class-metaclass super))
          (error "Incompatible metaclass for `~A': ~
                  `~A' isn't subclass of `~A' (of `~A')"
           name
           (sod-class-name metaclass)
           (sod-class-name (sod-class-metaclass super))
           (sod-class-name super)))))))

(defmethod finalize-sod-class ((class sod-class))
  (with-default-error-location (class)
    (ecase (sod-class-state class)
      ((nil)

       ;; If this fails, mark the class as a loss.
       (setf (sod-class-state class) :broken)

       ;; Finalize all of the superclasses.  There's some special pleading
       ;; here to make bootstrapping work: we don't try to finalize the
       ;; metaclass if we're a root class (no direct superclasses -- because
       ;; in that case the metaclass will have to be a subclass of us!), or
       ;; if it's equal to us.  This is enough to tie the knot at the top of
       ;; the class graph.
       (with-slots (name direct-superclasses metaclass) class
         (dolist (super direct-superclasses)
           (finalize-sod-class super))
         (unless (or (null direct-superclasses)
                     (eq class metaclass))
           (finalize-sod-class metaclass)))

       ;; Clobber the lists of items if they've not been set.
       (dolist (slot '(slots instance-initializers class-initializers
                       messages methods))
         (unless (slot-boundp class slot)
           (setf (slot-value class slot) nil)))

       ;; If the CPL hasn't been done yet, compute it.
       (with-slots (class-precedence-list) class
         (unless (slot-boundp class 'class-precedence-list)
           (setf class-precedence-list (compute-cpl class))))

       ;; If no metaclass has been established, then choose one.
       (with-slots (metaclass) class
         (unless (and (slot-boundp class 'metaclass) metaclass)
           (setf metaclass (guess-metaclass class))))

       ;; If no nickname has been set, choose a default.  This might cause
       ;; conflicts, but, well, the user should have chosen an explicit
       ;; nickname.
       (with-slots (name nickname) class
         (unless (and (slot-boundp class 'nickname) nickname)
           (setf nickname (string-downcase name))))

       ;; Check that the class is fairly sane.
       (check-sod-class class)

       ;; Determine the class's layout.
       (compute-chains class)

       ;; Done.
       (setf (sod-class-state class) :finalized)
       t)

      (:broken
       nil)

      (:finalized
       t))))

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