src/class-*.lisp: Improve metaclass selection.

[sod] / src / class-make-proto.lisp

;;; -*-lisp-*-
;;;
;;; Class construction 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)

;;;--------------------------------------------------------------------------
;;; Classes.

(export 'make-sod-class)
(defun make-sod-class (name superclasses pset &optional location)
  "Construct and return a new SOD class with the given NAME and SUPERCLASSES.

   This is the main constructor function for classes.  The protocol works as
   follows.  The `:lisp-metaclass' property in PSET is checked: if it exists,
   it must be a symbol naming a (CLOS) class, which is used in place of
   `sod-class'.  All of the arguments are then passed to `make-instance';
   further behaviour is left to the standard CLOS instance construction
   protocol; for example, `sod-class' defines an `:after'-method on
   `shared-initialize'.

   Minimal sanity checking is done during class construction; most of it is
   left for `finalize-sod-class' to do (via `check-sod-class')."

  (with-default-error-location (location)
    (let* ((pset (property-set pset))
	   (best-class (or (get-property pset :lisp-metaclass :symbol nil)
			   (select-minimal-class-property
			    superclasses #'class-of #'subtypep 'sod-class
			    "Lisp metaclass"
			    :present (lambda (class)
				       (format nil "`~S'"
					       (class-name class)))
			    :allow-empty t)))
	   (class (make-instance best-class
				 :name name
				 :superclasses superclasses
				 :location (file-location location)
				 :pset pset)))
      class)))

;;;--------------------------------------------------------------------------
;;; Slots and slot initializers.

(export 'make-sod-slot)
(defgeneric make-sod-slot (class name type pset &optional location)
  (:documentation
   "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.

   This is the main constructor function for slots.  This is a generic
   function primarily so that the CLASS can intervene in the construction
   process.  The default method uses the `:slot-class' property (defaulting
   to `sod-slot') to choose a (CLOS) class to instantiate.  The slot is then
   constructed by `make-instance' passing the arguments as initargs; further
   behaviour is left to the standard CLOS instance construction protocol; for
   example, `sod-slot' defines an `:after'-method on `shared-initialize'."))

(export 'make-sod-instance-initializer)
(defgeneric make-sod-instance-initializer
    (class nick name value pset &optional location)
  (:documentation
   "Construct and attach an instance slot initializer, to CLASS.

   This is the main constructor function for instance initializers.  This is
   a generic function primarily so that the CLASS can intervene in the
   construction process.  The default method looks up the slot using
   `find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to
   actually make the initializer object, and adds it to the appropriate list
   in CLASS."))

(export 'make-sod-class-initializer)
(defgeneric make-sod-class-initializer
    (class nick name value pset &optional location)
  (:documentation
   "Construct and attach a class slot initializer, to CLASS.

   This is the main constructor function for class initializers.  This is a
   generic function primarily so that the CLASS can intervene in the
   construction process.  The default method looks up the slot using
   `find-class-slot-by-name', calls `make-sod-initializer-using-slot' to
   actually make the initializer object, and adds it to the appropriate list
   in CLASS."))

(export 'make-sod-initializer-using-slot)
(defgeneric make-sod-initializer-using-slot
    (class slot init-class value pset location)
  (:documentation
   "Common construction protocol for slot initializers.

   This generic function does the common work for constructing instance and
   class initializers.  It can usefully be specialized according to both the
   class and slot types.  The default method uses the `:initializer-class'
   property (defaulting to INIT-CLASS) to choose a (CLOS) class to
   instantiate.  The slot is then constructed by `make-instance' passing the
   arguments as initargs; further behaviour is left to the standard CLOS
   instance construction protocol; for example, `sod-initializer' defines an
   `:after'-method on `shared-initialize'.

   Diagnosing unused properties is left for the caller (usually
   `make-sod-instance-initializer' or `make-sod-class-initializer') to do.
   The caller is also expected to have set `with-default-error-location' if
   appropriate.

   You are not expected to call this generic function directly; it's more
   useful as a place to hang methods for custom initializer classes."))

(export 'make-sod-user-initarg)
(defgeneric make-sod-user-initarg
    (class name type pset &optional default location)
  (:documentation
   "Attach a user-defined initialization keyword argument to the CLASS.

   The new argument has the given NAME and TYPE, and maybe a DEFAULT value.
   Currently, initialization arguments are just dumb objects held in a
   list."))

(export 'make-sod-slot-initarg)
(defgeneric make-sod-slot-initarg
    (class name nick slot-name pset &optional location)
  (:documentation
   "Attach an initialization keyword argument to a slot by name.

   The default method uses `find-instance-slot-by-name' to find the slot, and
   `make-slot-initarg-using-slot' to actually make and attach the initarg."))

(export 'make-sod-slot-initarg-using-slot)
(defgeneric make-sod-slot-initarg-using-slot
    (class name slot pset &optional location)
  (:documentation
   "Attach an initialization keyword argument to a SLOT.

   The argument's type is taken from the slot type.  Slot initargs can't have
   defaults: the slot's most-specific initializer is used instead.

   You are not expected to call this generic function directly; it's more
   useful as a place to hang methods for custom classes."))

(export 'sod-initarg-argument)
(defgeneric sod-initarg-argument (initarg)
  (:documentation "Returns an `argument' object for the initarg."))

(export 'make-sod-class-initfrag)
(defgeneric make-sod-class-initfrag (class frag pset &optional location)
  (:documentation
   "Attach an initialization fragment FRAG to the CLASS.

   Currently, initialization fragments are just dumb objects held in a
   list."))

(export 'make-sod-class-tearfrag)
(defgeneric make-sod-class-tearfrag (class frag pset &optional location)
  (:documentation
   "Attach a teardown fragment FRAG to the CLASS.

   Currently, teardown fragments are just dumb objects held in a
   list."))

;;;--------------------------------------------------------------------------
;;; Messages and methods.

(export 'make-sod-message)
(defgeneric make-sod-message (class name type pset &optional location)
  (:documentation
   "Construct and attach a new message with given NAME and TYPE, to CLASS.

   This is the main constructor function for messages.  This is a generic
   function primarily so that the CLASS can intervene in the construction
   process.  The default method uses the `:message-class' property to choose
   a (CLOS) class to instantiate; if no such property is provided but a
   `combination' property is present, then `aggregating-message' is chosen;
   otherwise `standard-message' is used.  The message is then constructed by
   `make-instance' passing the arguments as initargs; further behaviour is
   left to the standard CLOS instance construction protocol; for example,
   `sod-message' defines an `:after'-method on `shared-initialize'."))

(export 'make-sod-method)
(defgeneric make-sod-method
    (class nick name type body pset &optional location)
  (:documentation
   "Construct and attach a new method to CLASS.

   This is the main constructor function for methods.  This is a generic
   function primarily so that the CLASS can intervene in the message lookup
   process, though this is actually a fairly unlikely occurrence.

   The default method looks up the message using `find-message-by-name',
   invokes `make-sod-method-using-message' to make the method object, and
   then adds the method to the class's list of methods.  This split allows
   the message class to intervene in the class selection process, for
   example."))

(export 'make-sod-method-using-message)
(defgeneric make-sod-method-using-message
    (message class type body pset location)
  (:documentation
   "Main construction subroutine for method construction.

   This is a generic function so that it can be specialized according to both
   a class and -- more particularly -- a message.  The default method uses
   the `:method-class' property (defaulting to the result of calling
   `sod-message-method-class') to choose a (CLOS) class to instantiate.  The
   method is then constructed by `make-instance' passing the arguments as
   initargs; further behaviour is left to the standard CLOS instance
   construction protocol; for example, `sod-method' defines an
   `:after'-method on `shared-initialize'.

   Diagnosing unused properties is left for the caller (usually
   `make-sod-method') to do.  The caller is also expected to have set
   `with-default-error-location' if appropriate.

   You are not expected to call this generic function directly; it's more
   useful as a place to hang methods for custom method classes."))

(export 'sod-message-method-class)
(defgeneric sod-message-method-class (message class pset)
  (:documentation
   "Return the preferred class for methods on MESSAGE.

   The message can inspect the PSET to decide on a particular message.  A
   `:method-class' property will usually override this decision: it's then
   the programmer's responsibility to ensure that the selected method class
   is appropriate."))

(export 'check-message-type)
(defgeneric check-message-type (message type)
  (:documentation
   "Check that TYPE is a suitable type for MESSAGE.  Signal errors if not.

   This is separated out of `shared-initialize', where it's called, so that
   it can be overridden conveniently by subclasses."))

(export 'check-method-type)
(defgeneric check-method-type (method message type)
  (:documentation
   "Check that TYPE is a suitable type for METHOD.  Signal errors if not.

   This is separated out of `shared-initialize', where it's called, so that
   it can be overridden conveniently by subclasses."))

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